]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Matching subroutines in all sizes, shapes and colors. |
cbe34bb5 | 2 | Copyright (C) 2000-2017 Free Software Foundation, Inc. |
6de9cd9a DN |
3 | Contributed by Andy Vaught |
4 | ||
9fc4d79b | 5 | This file is part of GCC. |
6de9cd9a | 6 | |
9fc4d79b TS |
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 | |
d234d788 | 9 | Software Foundation; either version 3, or (at your option) any later |
9fc4d79b | 10 | version. |
6de9cd9a | 11 | |
9fc4d79b TS |
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. | |
6de9cd9a DN |
16 | |
17 | You should have received a copy of the GNU General Public License | |
d234d788 NC |
18 | along with GCC; see the file COPYING3. If not see |
19 | <http://www.gnu.org/licenses/>. */ | |
6de9cd9a | 20 | |
6de9cd9a DN |
21 | #include "config.h" |
22 | #include "system.h" | |
953bee7c | 23 | #include "coretypes.h" |
1916bcb5 | 24 | #include "options.h" |
6de9cd9a DN |
25 | #include "gfortran.h" |
26 | #include "match.h" | |
27 | #include "parse.h" | |
28 | ||
837c4b78 | 29 | int gfc_matching_ptr_assignment = 0; |
8fb74da4 | 30 | int gfc_matching_procptr_assignment = 0; |
3df684e2 | 31 | bool gfc_matching_prefix = false; |
6de9cd9a | 32 | |
7431bf06 JW |
33 | /* Stack of SELECT TYPE statements. */ |
34 | gfc_select_type_stack *select_type_stack = NULL; | |
cf2b3c22 | 35 | |
5bab4c96 PT |
36 | /* List of type parameter expressions. */ |
37 | gfc_actual_arglist *type_param_spec_list; | |
38 | ||
ba3ba492 RS |
39 | /* For debugging and diagnostic purposes. Return the textual representation |
40 | of the intrinsic operator OP. */ | |
41 | const char * | |
42 | gfc_op2string (gfc_intrinsic_op op) | |
43 | { | |
44 | switch (op) | |
45 | { | |
46 | case INTRINSIC_UPLUS: | |
47 | case INTRINSIC_PLUS: | |
48 | return "+"; | |
49 | ||
50 | case INTRINSIC_UMINUS: | |
51 | case INTRINSIC_MINUS: | |
52 | return "-"; | |
53 | ||
54 | case INTRINSIC_POWER: | |
55 | return "**"; | |
56 | case INTRINSIC_CONCAT: | |
57 | return "//"; | |
58 | case INTRINSIC_TIMES: | |
59 | return "*"; | |
60 | case INTRINSIC_DIVIDE: | |
61 | return "/"; | |
62 | ||
63 | case INTRINSIC_AND: | |
64 | return ".and."; | |
65 | case INTRINSIC_OR: | |
66 | return ".or."; | |
67 | case INTRINSIC_EQV: | |
68 | return ".eqv."; | |
69 | case INTRINSIC_NEQV: | |
70 | return ".neqv."; | |
71 | ||
72 | case INTRINSIC_EQ_OS: | |
73 | return ".eq."; | |
74 | case INTRINSIC_EQ: | |
75 | return "=="; | |
76 | case INTRINSIC_NE_OS: | |
77 | return ".ne."; | |
78 | case INTRINSIC_NE: | |
79 | return "/="; | |
80 | case INTRINSIC_GE_OS: | |
81 | return ".ge."; | |
82 | case INTRINSIC_GE: | |
83 | return ">="; | |
84 | case INTRINSIC_LE_OS: | |
85 | return ".le."; | |
86 | case INTRINSIC_LE: | |
87 | return "<="; | |
88 | case INTRINSIC_LT_OS: | |
89 | return ".lt."; | |
90 | case INTRINSIC_LT: | |
91 | return "<"; | |
92 | case INTRINSIC_GT_OS: | |
93 | return ".gt."; | |
94 | case INTRINSIC_GT: | |
95 | return ">"; | |
96 | case INTRINSIC_NOT: | |
97 | return ".not."; | |
98 | ||
99 | case INTRINSIC_ASSIGN: | |
100 | return "="; | |
101 | ||
102 | case INTRINSIC_PARENTHESES: | |
103 | return "parens"; | |
104 | ||
898344a9 SK |
105 | case INTRINSIC_NONE: |
106 | return "none"; | |
107 | ||
e73d3ca6 PT |
108 | /* DTIO */ |
109 | case INTRINSIC_FORMATTED: | |
110 | return "formatted"; | |
111 | case INTRINSIC_UNFORMATTED: | |
112 | return "unformatted"; | |
113 | ||
ba3ba492 RS |
114 | default: |
115 | break; | |
116 | } | |
117 | ||
118 | gfc_internal_error ("gfc_op2string(): Bad code"); | |
119 | /* Not reached. */ | |
120 | } | |
121 | ||
6de9cd9a DN |
122 | |
123 | /******************** Generic matching subroutines ************************/ | |
124 | ||
f6288c24 FR |
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, | |
5bab4c96 PT |
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." | |
f6288c24 FR |
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 | |
5bab4c96 | 143 | error. |
f6288c24 FR |
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 | gfc_match_member_sep(gfc_symbol *sym) | |
152 | { | |
153 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
154 | locus dot_loc, start_loc; | |
155 | gfc_intrinsic_op iop; | |
156 | match m; | |
157 | gfc_symbol *tsym; | |
158 | gfc_component *c = NULL; | |
159 | ||
160 | /* What a relief: '%' is an unambiguous member separator. */ | |
161 | if (gfc_match_char ('%') == MATCH_YES) | |
162 | return MATCH_YES; | |
163 | ||
164 | /* Beware ye who enter here. */ | |
f6d17ecd | 165 | if (!flag_dec_structure || !sym) |
f6288c24 FR |
166 | return MATCH_NO; |
167 | ||
168 | tsym = NULL; | |
169 | ||
170 | /* We may be given either a derived type variable or the derived type | |
5bab4c96 | 171 | declaration itself (which actually contains the components); |
f6288c24 FR |
172 | we need the latter to search for components. */ |
173 | if (gfc_fl_struct (sym->attr.flavor)) | |
174 | tsym = sym; | |
175 | else if (gfc_bt_struct (sym->ts.type)) | |
176 | tsym = sym->ts.u.derived; | |
177 | ||
178 | iop = INTRINSIC_NONE; | |
179 | name[0] = '\0'; | |
180 | m = MATCH_NO; | |
181 | ||
182 | /* If we have to reject come back here later. */ | |
183 | start_loc = gfc_current_locus; | |
184 | ||
185 | /* Look for a component access next. */ | |
186 | if (gfc_match_char ('.') != MATCH_YES) | |
187 | return MATCH_NO; | |
188 | ||
189 | /* If we accept, come back here. */ | |
190 | dot_loc = gfc_current_locus; | |
191 | ||
192 | /* Try to match a symbol name following the dot. */ | |
193 | if (gfc_match_name (name) != MATCH_YES) | |
194 | { | |
195 | gfc_error ("Expected structure component or operator name " | |
196 | "after '.' at %C"); | |
197 | goto error; | |
198 | } | |
199 | ||
200 | /* If no dot follows we have "x.y" which should be a component access. */ | |
201 | if (gfc_match_char ('.') != MATCH_YES) | |
202 | 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 | if (gfc_find_uop (name, sym->ns) != NULL) | |
209 | goto no; | |
210 | ||
5bab4c96 | 211 | /* Match accesses to existing derived-type components for |
f6288c24 FR |
212 | derived-type vars: "x.y.z" = (x->y)->z */ |
213 | c = gfc_find_component(tsym, name, false, true, NULL); | |
214 | if (c && (gfc_bt_struct (c->ts.type) || c->ts.type == BT_CLASS)) | |
215 | goto yes; | |
216 | ||
217 | /* If y is not a component or has no members, try intrinsic operators. */ | |
218 | gfc_current_locus = start_loc; | |
219 | if (gfc_match_intrinsic_op (&iop) != MATCH_YES) | |
220 | { | |
221 | /* If ".y." is not an intrinsic operator but y was a valid non- | |
5bab4c96 | 222 | structure component, match and leave the trailing dot to be |
f6288c24 FR |
223 | dealt with later. */ |
224 | if (c) | |
225 | goto yes; | |
226 | ||
2f029c08 | 227 | gfc_error ("%qs is neither a defined operator nor a " |
f6288c24 FR |
228 | "structure component in dotted string at %C", name); |
229 | goto error; | |
230 | } | |
231 | ||
232 | /* .y. is an intrinsic operator, overriding any possible member access. */ | |
233 | goto no; | |
234 | ||
235 | /* Return keeping the current locus consistent with the match result. */ | |
236 | error: | |
237 | m = MATCH_ERROR; | |
238 | no: | |
239 | gfc_current_locus = start_loc; | |
240 | return m; | |
241 | yes: | |
242 | gfc_current_locus = dot_loc; | |
243 | return MATCH_YES; | |
244 | } | |
245 | ||
246 | ||
f9b9fb82 JD |
247 | /* This function scans the current statement counting the opened and closed |
248 | parenthesis to make sure they are balanced. */ | |
249 | ||
250 | match | |
251 | gfc_match_parens (void) | |
252 | { | |
253 | locus old_loc, where; | |
696abb30 JD |
254 | int count; |
255 | gfc_instring instring; | |
8fc541d3 | 256 | gfc_char_t c, quote; |
f9b9fb82 JD |
257 | |
258 | old_loc = gfc_current_locus; | |
259 | count = 0; | |
696abb30 | 260 | instring = NONSTRING; |
f9b9fb82 JD |
261 | quote = ' '; |
262 | ||
263 | for (;;) | |
264 | { | |
265 | c = gfc_next_char_literal (instring); | |
266 | if (c == '\n') | |
267 | break; | |
268 | if (quote == ' ' && ((c == '\'') || (c == '"'))) | |
269 | { | |
8fc541d3 | 270 | quote = c; |
696abb30 | 271 | instring = INSTRING_WARN; |
f9b9fb82 JD |
272 | continue; |
273 | } | |
274 | if (quote != ' ' && c == quote) | |
275 | { | |
276 | quote = ' '; | |
696abb30 | 277 | instring = NONSTRING; |
f9b9fb82 JD |
278 | continue; |
279 | } | |
280 | ||
281 | if (c == '(' && quote == ' ') | |
282 | { | |
283 | count++; | |
284 | where = gfc_current_locus; | |
285 | } | |
286 | if (c == ')' && quote == ' ') | |
287 | { | |
288 | count--; | |
289 | where = gfc_current_locus; | |
290 | } | |
291 | } | |
292 | ||
293 | gfc_current_locus = old_loc; | |
294 | ||
295 | if (count > 0) | |
296 | { | |
a4d9b221 | 297 | gfc_error ("Missing %<)%> in statement at or before %L", &where); |
f9b9fb82 JD |
298 | return MATCH_ERROR; |
299 | } | |
300 | if (count < 0) | |
301 | { | |
a4d9b221 | 302 | gfc_error ("Missing %<(%> in statement at or before %L", &where); |
f9b9fb82 JD |
303 | return MATCH_ERROR; |
304 | } | |
305 | ||
306 | return MATCH_YES; | |
307 | } | |
308 | ||
309 | ||
a88a266c SK |
310 | /* See if the next character is a special character that has |
311 | escaped by a \ via the -fbackslash option. */ | |
312 | ||
313 | match | |
8fc541d3 | 314 | gfc_match_special_char (gfc_char_t *res) |
a88a266c | 315 | { |
8fc541d3 FXC |
316 | int len, i; |
317 | gfc_char_t c, n; | |
a88a266c SK |
318 | match m; |
319 | ||
320 | m = MATCH_YES; | |
321 | ||
696abb30 | 322 | switch ((c = gfc_next_char_literal (INSTRING_WARN))) |
a88a266c SK |
323 | { |
324 | case 'a': | |
8fc541d3 | 325 | *res = '\a'; |
a88a266c SK |
326 | break; |
327 | case 'b': | |
8fc541d3 | 328 | *res = '\b'; |
a88a266c SK |
329 | break; |
330 | case 't': | |
8fc541d3 | 331 | *res = '\t'; |
a88a266c SK |
332 | break; |
333 | case 'f': | |
8fc541d3 | 334 | *res = '\f'; |
a88a266c SK |
335 | break; |
336 | case 'n': | |
8fc541d3 | 337 | *res = '\n'; |
a88a266c SK |
338 | break; |
339 | case 'r': | |
8fc541d3 | 340 | *res = '\r'; |
a88a266c SK |
341 | break; |
342 | case 'v': | |
8fc541d3 | 343 | *res = '\v'; |
a88a266c SK |
344 | break; |
345 | case '\\': | |
8fc541d3 | 346 | *res = '\\'; |
a88a266c SK |
347 | break; |
348 | case '0': | |
8fc541d3 FXC |
349 | *res = '\0'; |
350 | break; | |
351 | ||
352 | case 'x': | |
353 | case 'u': | |
354 | case 'U': | |
355 | /* Hexadecimal form of wide characters. */ | |
356 | len = (c == 'x' ? 2 : (c == 'u' ? 4 : 8)); | |
357 | n = 0; | |
358 | for (i = 0; i < len; i++) | |
359 | { | |
360 | char buf[2] = { '\0', '\0' }; | |
361 | ||
696abb30 | 362 | c = gfc_next_char_literal (INSTRING_WARN); |
8fc541d3 FXC |
363 | if (!gfc_wide_fits_in_byte (c) |
364 | || !gfc_check_digit ((unsigned char) c, 16)) | |
365 | return MATCH_NO; | |
366 | ||
367 | buf[0] = (unsigned char) c; | |
368 | n = n << 4; | |
369 | n += strtol (buf, NULL, 16); | |
370 | } | |
371 | *res = n; | |
a88a266c | 372 | break; |
8fc541d3 | 373 | |
a88a266c SK |
374 | default: |
375 | /* Unknown backslash codes are simply not expanded. */ | |
376 | m = MATCH_NO; | |
377 | break; | |
378 | } | |
379 | ||
380 | return m; | |
381 | } | |
382 | ||
383 | ||
6de9cd9a DN |
384 | /* In free form, match at least one space. Always matches in fixed |
385 | form. */ | |
386 | ||
387 | match | |
388 | gfc_match_space (void) | |
389 | { | |
390 | locus old_loc; | |
8fc541d3 | 391 | char c; |
6de9cd9a | 392 | |
d4fa05b9 | 393 | if (gfc_current_form == FORM_FIXED) |
6de9cd9a DN |
394 | return MATCH_YES; |
395 | ||
63645982 | 396 | old_loc = gfc_current_locus; |
6de9cd9a | 397 | |
8fc541d3 | 398 | c = gfc_next_ascii_char (); |
6de9cd9a DN |
399 | if (!gfc_is_whitespace (c)) |
400 | { | |
63645982 | 401 | gfc_current_locus = old_loc; |
6de9cd9a DN |
402 | return MATCH_NO; |
403 | } | |
404 | ||
405 | gfc_gobble_whitespace (); | |
406 | ||
407 | return MATCH_YES; | |
408 | } | |
409 | ||
410 | ||
411 | /* Match an end of statement. End of statement is optional | |
412 | whitespace, followed by a ';' or '\n' or comment '!'. If a | |
413 | semicolon is found, we continue to eat whitespace and semicolons. */ | |
414 | ||
415 | match | |
416 | gfc_match_eos (void) | |
417 | { | |
418 | locus old_loc; | |
8fc541d3 FXC |
419 | int flag; |
420 | char c; | |
6de9cd9a DN |
421 | |
422 | flag = 0; | |
423 | ||
424 | for (;;) | |
425 | { | |
63645982 | 426 | old_loc = gfc_current_locus; |
6de9cd9a DN |
427 | gfc_gobble_whitespace (); |
428 | ||
8fc541d3 | 429 | c = gfc_next_ascii_char (); |
6de9cd9a DN |
430 | switch (c) |
431 | { | |
432 | case '!': | |
433 | do | |
434 | { | |
8fc541d3 | 435 | c = gfc_next_ascii_char (); |
6de9cd9a DN |
436 | } |
437 | while (c != '\n'); | |
438 | ||
66e4ab31 | 439 | /* Fall through. */ |
6de9cd9a DN |
440 | |
441 | case '\n': | |
442 | return MATCH_YES; | |
443 | ||
444 | case ';': | |
445 | flag = 1; | |
446 | continue; | |
447 | } | |
448 | ||
449 | break; | |
450 | } | |
451 | ||
63645982 | 452 | gfc_current_locus = old_loc; |
6de9cd9a DN |
453 | return (flag) ? MATCH_YES : MATCH_NO; |
454 | } | |
455 | ||
456 | ||
457 | /* Match a literal integer on the input, setting the value on | |
458 | MATCH_YES. Literal ints occur in kind-parameters as well as | |
5cf54585 TS |
459 | old-style character length specifications. If cnt is non-NULL it |
460 | will be set to the number of digits. */ | |
6de9cd9a DN |
461 | |
462 | match | |
8a8f7eca | 463 | gfc_match_small_literal_int (int *value, int *cnt) |
6de9cd9a DN |
464 | { |
465 | locus old_loc; | |
466 | char c; | |
8a8f7eca | 467 | int i, j; |
6de9cd9a | 468 | |
63645982 | 469 | old_loc = gfc_current_locus; |
6de9cd9a | 470 | |
8fc541d3 | 471 | *value = -1; |
6de9cd9a | 472 | gfc_gobble_whitespace (); |
8fc541d3 | 473 | c = gfc_next_ascii_char (); |
5cf54585 TS |
474 | if (cnt) |
475 | *cnt = 0; | |
6de9cd9a DN |
476 | |
477 | if (!ISDIGIT (c)) | |
478 | { | |
63645982 | 479 | gfc_current_locus = old_loc; |
6de9cd9a DN |
480 | return MATCH_NO; |
481 | } | |
482 | ||
483 | i = c - '0'; | |
8a8f7eca | 484 | j = 1; |
6de9cd9a DN |
485 | |
486 | for (;;) | |
487 | { | |
63645982 | 488 | old_loc = gfc_current_locus; |
8fc541d3 | 489 | c = gfc_next_ascii_char (); |
6de9cd9a DN |
490 | |
491 | if (!ISDIGIT (c)) | |
492 | break; | |
493 | ||
494 | i = 10 * i + c - '0'; | |
8a8f7eca | 495 | j++; |
6de9cd9a DN |
496 | |
497 | if (i > 99999999) | |
498 | { | |
499 | gfc_error ("Integer too large at %C"); | |
500 | return MATCH_ERROR; | |
501 | } | |
502 | } | |
503 | ||
63645982 | 504 | gfc_current_locus = old_loc; |
6de9cd9a DN |
505 | |
506 | *value = i; | |
5cf54585 TS |
507 | if (cnt) |
508 | *cnt = j; | |
6de9cd9a DN |
509 | return MATCH_YES; |
510 | } | |
511 | ||
512 | ||
513 | /* Match a small, constant integer expression, like in a kind | |
514 | statement. On MATCH_YES, 'value' is set. */ | |
515 | ||
516 | match | |
517 | gfc_match_small_int (int *value) | |
518 | { | |
519 | gfc_expr *expr; | |
6de9cd9a DN |
520 | match m; |
521 | int i; | |
522 | ||
523 | m = gfc_match_expr (&expr); | |
524 | if (m != MATCH_YES) | |
525 | return m; | |
526 | ||
51f03c6b JJ |
527 | if (gfc_extract_int (expr, &i, 1)) |
528 | m = MATCH_ERROR; | |
6de9cd9a DN |
529 | gfc_free_expr (expr); |
530 | ||
6de9cd9a DN |
531 | *value = i; |
532 | return m; | |
533 | } | |
534 | ||
535 | ||
a8b3b0b6 CR |
536 | /* This function is the same as the gfc_match_small_int, except that |
537 | we're keeping the pointer to the expr. This function could just be | |
538 | removed and the previously mentioned one modified, though all calls | |
539 | to it would have to be modified then (and there were a number of | |
540 | them). Return MATCH_ERROR if fail to extract the int; otherwise, | |
541 | return the result of gfc_match_expr(). The expr (if any) that was | |
542 | matched is returned in the parameter expr. */ | |
543 | ||
544 | match | |
545 | gfc_match_small_int_expr (int *value, gfc_expr **expr) | |
546 | { | |
a8b3b0b6 CR |
547 | match m; |
548 | int i; | |
549 | ||
550 | m = gfc_match_expr (expr); | |
551 | if (m != MATCH_YES) | |
552 | return m; | |
553 | ||
51f03c6b JJ |
554 | if (gfc_extract_int (*expr, &i, 1)) |
555 | m = MATCH_ERROR; | |
a8b3b0b6 CR |
556 | |
557 | *value = i; | |
558 | return m; | |
559 | } | |
560 | ||
561 | ||
6de9cd9a DN |
562 | /* Matches a statement label. Uses gfc_match_small_literal_int() to |
563 | do most of the work. */ | |
564 | ||
565 | match | |
b251af97 | 566 | gfc_match_st_label (gfc_st_label **label) |
6de9cd9a DN |
567 | { |
568 | locus old_loc; | |
569 | match m; | |
8a8f7eca | 570 | int i, cnt; |
6de9cd9a | 571 | |
63645982 | 572 | old_loc = gfc_current_locus; |
6de9cd9a | 573 | |
8a8f7eca | 574 | m = gfc_match_small_literal_int (&i, &cnt); |
6de9cd9a DN |
575 | if (m != MATCH_YES) |
576 | return m; | |
577 | ||
8a8f7eca | 578 | if (cnt > 5) |
6de9cd9a | 579 | { |
8a8f7eca SK |
580 | gfc_error ("Too many digits in statement label at %C"); |
581 | goto cleanup; | |
6de9cd9a DN |
582 | } |
583 | ||
a34a91f0 | 584 | if (i == 0) |
8a8f7eca SK |
585 | { |
586 | gfc_error ("Statement label at %C is zero"); | |
587 | goto cleanup; | |
588 | } | |
589 | ||
590 | *label = gfc_get_st_label (i); | |
591 | return MATCH_YES; | |
592 | ||
593 | cleanup: | |
594 | ||
63645982 | 595 | gfc_current_locus = old_loc; |
6de9cd9a DN |
596 | return MATCH_ERROR; |
597 | } | |
598 | ||
599 | ||
600 | /* Match and validate a label associated with a named IF, DO or SELECT | |
601 | statement. If the symbol does not have the label attribute, we add | |
602 | it. We also make sure the symbol does not refer to another | |
603 | (active) block. A matched label is pointed to by gfc_new_block. */ | |
604 | ||
605 | match | |
606 | gfc_match_label (void) | |
607 | { | |
608 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
6de9cd9a DN |
609 | match m; |
610 | ||
611 | gfc_new_block = NULL; | |
612 | ||
613 | m = gfc_match (" %n :", name); | |
614 | if (m != MATCH_YES) | |
615 | return m; | |
616 | ||
617 | if (gfc_get_symbol (name, NULL, &gfc_new_block)) | |
618 | { | |
a4d9b221 | 619 | gfc_error ("Label name %qs at %C is ambiguous", name); |
6de9cd9a DN |
620 | return MATCH_ERROR; |
621 | } | |
622 | ||
cb1d4dce SK |
623 | if (gfc_new_block->attr.flavor == FL_LABEL) |
624 | { | |
a4d9b221 | 625 | gfc_error ("Duplicate construct label %qs at %C", name); |
cb1d4dce SK |
626 | return MATCH_ERROR; |
627 | } | |
6de9cd9a | 628 | |
5bab4c96 | 629 | if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL, |
524af0d6 | 630 | gfc_new_block->name, NULL)) |
cb1d4dce | 631 | return MATCH_ERROR; |
6de9cd9a DN |
632 | |
633 | return MATCH_YES; | |
634 | } | |
635 | ||
636 | ||
6de9cd9a | 637 | /* See if the current input looks like a name of some sort. Modifies |
090021e9 BM |
638 | the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. |
639 | Note that options.c restricts max_identifier_length to not more | |
640 | than GFC_MAX_SYMBOL_LEN. */ | |
6de9cd9a DN |
641 | |
642 | match | |
643 | gfc_match_name (char *buffer) | |
644 | { | |
645 | locus old_loc; | |
8fc541d3 FXC |
646 | int i; |
647 | char c; | |
6de9cd9a | 648 | |
63645982 | 649 | old_loc = gfc_current_locus; |
6de9cd9a DN |
650 | gfc_gobble_whitespace (); |
651 | ||
8fc541d3 | 652 | c = gfc_next_ascii_char (); |
c61819ff | 653 | if (!(ISALPHA (c) || (c == '_' && flag_allow_leading_underscore))) |
6de9cd9a | 654 | { |
83eb71f4 SK |
655 | /* Special cases for unary minus and plus, which allows for a sensible |
656 | error message for code of the form 'c = exp(-a*b) )' where an | |
657 | extra ')' appears at the end of statement. */ | |
658 | if (!gfc_error_flag_test () && c != '(' && c != '-' && c != '+') | |
b251af97 | 659 | gfc_error ("Invalid character in name at %C"); |
63645982 | 660 | gfc_current_locus = old_loc; |
6de9cd9a DN |
661 | return MATCH_NO; |
662 | } | |
663 | ||
664 | i = 0; | |
665 | ||
666 | do | |
667 | { | |
668 | buffer[i++] = c; | |
669 | ||
670 | if (i > gfc_option.max_identifier_length) | |
671 | { | |
672 | gfc_error ("Name at %C is too long"); | |
673 | return MATCH_ERROR; | |
674 | } | |
675 | ||
63645982 | 676 | old_loc = gfc_current_locus; |
8fc541d3 | 677 | c = gfc_next_ascii_char (); |
6de9cd9a | 678 | } |
c61819ff | 679 | while (ISALNUM (c) || c == '_' || (flag_dollar_ok && c == '$')); |
6de9cd9a | 680 | |
c61819ff | 681 | if (c == '$' && !flag_dollar_ok) |
89a5afda | 682 | { |
29e0597e TB |
683 | gfc_fatal_error ("Invalid character %<$%> at %L. Use %<-fdollar-ok%> to " |
684 | "allow it as an extension", &old_loc); | |
89a5afda TB |
685 | return MATCH_ERROR; |
686 | } | |
687 | ||
6de9cd9a | 688 | buffer[i] = '\0'; |
63645982 | 689 | gfc_current_locus = old_loc; |
6de9cd9a DN |
690 | |
691 | return MATCH_YES; | |
692 | } | |
693 | ||
694 | ||
695 | /* Match a symbol on the input. Modifies the pointer to the symbol | |
696 | pointer if successful. */ | |
697 | ||
698 | match | |
b251af97 | 699 | gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc) |
6de9cd9a DN |
700 | { |
701 | char buffer[GFC_MAX_SYMBOL_LEN + 1]; | |
702 | match m; | |
703 | ||
704 | m = gfc_match_name (buffer); | |
705 | if (m != MATCH_YES) | |
706 | return m; | |
707 | ||
708 | if (host_assoc) | |
709 | return (gfc_get_ha_sym_tree (buffer, matched_symbol)) | |
66e4ab31 | 710 | ? MATCH_ERROR : MATCH_YES; |
6de9cd9a | 711 | |
08a6b8e0 | 712 | if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false)) |
6de9cd9a DN |
713 | return MATCH_ERROR; |
714 | ||
715 | return MATCH_YES; | |
716 | } | |
717 | ||
718 | ||
719 | match | |
b251af97 | 720 | gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc) |
6de9cd9a DN |
721 | { |
722 | gfc_symtree *st; | |
723 | match m; | |
724 | ||
725 | m = gfc_match_sym_tree (&st, host_assoc); | |
726 | ||
727 | if (m == MATCH_YES) | |
728 | { | |
729 | if (st) | |
b251af97 | 730 | *matched_symbol = st->n.sym; |
6de9cd9a | 731 | else |
b251af97 | 732 | *matched_symbol = NULL; |
6de9cd9a | 733 | } |
32cafd73 MH |
734 | else |
735 | *matched_symbol = NULL; | |
6de9cd9a DN |
736 | return m; |
737 | } | |
738 | ||
b251af97 | 739 | |
8b704316 PT |
740 | /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching, |
741 | we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this | |
6de9cd9a DN |
742 | in matchexp.c. */ |
743 | ||
744 | match | |
b251af97 | 745 | gfc_match_intrinsic_op (gfc_intrinsic_op *result) |
6de9cd9a | 746 | { |
f4d8e0d1 | 747 | locus orig_loc = gfc_current_locus; |
8fc541d3 | 748 | char ch; |
6de9cd9a | 749 | |
f4d8e0d1 | 750 | gfc_gobble_whitespace (); |
8fc541d3 | 751 | ch = gfc_next_ascii_char (); |
f4d8e0d1 RS |
752 | switch (ch) |
753 | { | |
754 | case '+': | |
755 | /* Matched "+". */ | |
756 | *result = INTRINSIC_PLUS; | |
757 | return MATCH_YES; | |
6de9cd9a | 758 | |
f4d8e0d1 RS |
759 | case '-': |
760 | /* Matched "-". */ | |
761 | *result = INTRINSIC_MINUS; | |
762 | return MATCH_YES; | |
6de9cd9a | 763 | |
f4d8e0d1 | 764 | case '=': |
8fc541d3 | 765 | if (gfc_next_ascii_char () == '=') |
f4d8e0d1 RS |
766 | { |
767 | /* Matched "==". */ | |
768 | *result = INTRINSIC_EQ; | |
769 | return MATCH_YES; | |
770 | } | |
771 | break; | |
772 | ||
773 | case '<': | |
8fc541d3 | 774 | if (gfc_peek_ascii_char () == '=') |
f4d8e0d1 RS |
775 | { |
776 | /* Matched "<=". */ | |
8fc541d3 | 777 | gfc_next_ascii_char (); |
f4d8e0d1 RS |
778 | *result = INTRINSIC_LE; |
779 | return MATCH_YES; | |
780 | } | |
781 | /* Matched "<". */ | |
782 | *result = INTRINSIC_LT; | |
783 | return MATCH_YES; | |
784 | ||
785 | case '>': | |
8fc541d3 | 786 | if (gfc_peek_ascii_char () == '=') |
f4d8e0d1 RS |
787 | { |
788 | /* Matched ">=". */ | |
8fc541d3 | 789 | gfc_next_ascii_char (); |
f4d8e0d1 RS |
790 | *result = INTRINSIC_GE; |
791 | return MATCH_YES; | |
792 | } | |
793 | /* Matched ">". */ | |
794 | *result = INTRINSIC_GT; | |
795 | return MATCH_YES; | |
796 | ||
797 | case '*': | |
8fc541d3 | 798 | if (gfc_peek_ascii_char () == '*') |
f4d8e0d1 RS |
799 | { |
800 | /* Matched "**". */ | |
8fc541d3 | 801 | gfc_next_ascii_char (); |
f4d8e0d1 RS |
802 | *result = INTRINSIC_POWER; |
803 | return MATCH_YES; | |
804 | } | |
805 | /* Matched "*". */ | |
806 | *result = INTRINSIC_TIMES; | |
807 | return MATCH_YES; | |
808 | ||
809 | case '/': | |
8fc541d3 | 810 | ch = gfc_peek_ascii_char (); |
f4d8e0d1 RS |
811 | if (ch == '=') |
812 | { | |
813 | /* Matched "/=". */ | |
8fc541d3 | 814 | gfc_next_ascii_char (); |
f4d8e0d1 RS |
815 | *result = INTRINSIC_NE; |
816 | return MATCH_YES; | |
817 | } | |
818 | else if (ch == '/') | |
819 | { | |
820 | /* Matched "//". */ | |
8fc541d3 | 821 | gfc_next_ascii_char (); |
f4d8e0d1 RS |
822 | *result = INTRINSIC_CONCAT; |
823 | return MATCH_YES; | |
824 | } | |
825 | /* Matched "/". */ | |
826 | *result = INTRINSIC_DIVIDE; | |
827 | return MATCH_YES; | |
828 | ||
829 | case '.': | |
8fc541d3 | 830 | ch = gfc_next_ascii_char (); |
f4d8e0d1 RS |
831 | switch (ch) |
832 | { | |
833 | case 'a': | |
8fc541d3 FXC |
834 | if (gfc_next_ascii_char () == 'n' |
835 | && gfc_next_ascii_char () == 'd' | |
836 | && gfc_next_ascii_char () == '.') | |
f4d8e0d1 RS |
837 | { |
838 | /* Matched ".and.". */ | |
839 | *result = INTRINSIC_AND; | |
840 | return MATCH_YES; | |
841 | } | |
842 | break; | |
843 | ||
844 | case 'e': | |
8fc541d3 | 845 | if (gfc_next_ascii_char () == 'q') |
f4d8e0d1 | 846 | { |
8fc541d3 | 847 | ch = gfc_next_ascii_char (); |
f4d8e0d1 RS |
848 | if (ch == '.') |
849 | { | |
850 | /* Matched ".eq.". */ | |
851 | *result = INTRINSIC_EQ_OS; | |
852 | return MATCH_YES; | |
853 | } | |
854 | else if (ch == 'v') | |
855 | { | |
8fc541d3 | 856 | if (gfc_next_ascii_char () == '.') |
f4d8e0d1 RS |
857 | { |
858 | /* Matched ".eqv.". */ | |
859 | *result = INTRINSIC_EQV; | |
860 | return MATCH_YES; | |
861 | } | |
862 | } | |
863 | } | |
864 | break; | |
865 | ||
866 | case 'g': | |
8fc541d3 | 867 | ch = gfc_next_ascii_char (); |
f4d8e0d1 RS |
868 | if (ch == 'e') |
869 | { | |
8fc541d3 | 870 | if (gfc_next_ascii_char () == '.') |
f4d8e0d1 RS |
871 | { |
872 | /* Matched ".ge.". */ | |
873 | *result = INTRINSIC_GE_OS; | |
874 | return MATCH_YES; | |
875 | } | |
876 | } | |
877 | else if (ch == 't') | |
878 | { | |
8fc541d3 | 879 | if (gfc_next_ascii_char () == '.') |
f4d8e0d1 RS |
880 | { |
881 | /* Matched ".gt.". */ | |
882 | *result = INTRINSIC_GT_OS; | |
883 | return MATCH_YES; | |
884 | } | |
885 | } | |
886 | break; | |
887 | ||
888 | case 'l': | |
8fc541d3 | 889 | ch = gfc_next_ascii_char (); |
f4d8e0d1 RS |
890 | if (ch == 'e') |
891 | { | |
8fc541d3 | 892 | if (gfc_next_ascii_char () == '.') |
f4d8e0d1 RS |
893 | { |
894 | /* Matched ".le.". */ | |
895 | *result = INTRINSIC_LE_OS; | |
896 | return MATCH_YES; | |
897 | } | |
898 | } | |
899 | else if (ch == 't') | |
900 | { | |
8fc541d3 | 901 | if (gfc_next_ascii_char () == '.') |
f4d8e0d1 RS |
902 | { |
903 | /* Matched ".lt.". */ | |
904 | *result = INTRINSIC_LT_OS; | |
905 | return MATCH_YES; | |
906 | } | |
907 | } | |
908 | break; | |
909 | ||
910 | case 'n': | |
8fc541d3 | 911 | ch = gfc_next_ascii_char (); |
f4d8e0d1 RS |
912 | if (ch == 'e') |
913 | { | |
8fc541d3 | 914 | ch = gfc_next_ascii_char (); |
f4d8e0d1 RS |
915 | if (ch == '.') |
916 | { | |
917 | /* Matched ".ne.". */ | |
918 | *result = INTRINSIC_NE_OS; | |
919 | return MATCH_YES; | |
920 | } | |
921 | else if (ch == 'q') | |
922 | { | |
8fc541d3 FXC |
923 | if (gfc_next_ascii_char () == 'v' |
924 | && gfc_next_ascii_char () == '.') | |
f4d8e0d1 RS |
925 | { |
926 | /* Matched ".neqv.". */ | |
927 | *result = INTRINSIC_NEQV; | |
928 | return MATCH_YES; | |
929 | } | |
930 | } | |
931 | } | |
932 | else if (ch == 'o') | |
933 | { | |
8fc541d3 FXC |
934 | if (gfc_next_ascii_char () == 't' |
935 | && gfc_next_ascii_char () == '.') | |
f4d8e0d1 RS |
936 | { |
937 | /* Matched ".not.". */ | |
938 | *result = INTRINSIC_NOT; | |
939 | return MATCH_YES; | |
940 | } | |
941 | } | |
942 | break; | |
943 | ||
944 | case 'o': | |
8fc541d3 FXC |
945 | if (gfc_next_ascii_char () == 'r' |
946 | && gfc_next_ascii_char () == '.') | |
f4d8e0d1 RS |
947 | { |
948 | /* Matched ".or.". */ | |
949 | *result = INTRINSIC_OR; | |
950 | return MATCH_YES; | |
951 | } | |
952 | break; | |
953 | ||
1cf1719b FR |
954 | case 'x': |
955 | if (gfc_next_ascii_char () == 'o' | |
956 | && gfc_next_ascii_char () == 'r' | |
957 | && gfc_next_ascii_char () == '.') | |
958 | { | |
959 | if (!gfc_notify_std (GFC_STD_LEGACY, ".XOR. operator at %C")) | |
960 | return MATCH_ERROR; | |
961 | /* Matched ".xor." - equivalent to ".neqv.". */ | |
962 | *result = INTRINSIC_NEQV; | |
963 | return MATCH_YES; | |
964 | } | |
965 | break; | |
966 | ||
f4d8e0d1 RS |
967 | default: |
968 | break; | |
969 | } | |
970 | break; | |
971 | ||
972 | default: | |
973 | break; | |
974 | } | |
975 | ||
976 | gfc_current_locus = orig_loc; | |
977 | return MATCH_NO; | |
6de9cd9a DN |
978 | } |
979 | ||
980 | ||
981 | /* Match a loop control phrase: | |
982 | ||
983 | <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ] | |
984 | ||
985 | If the final integer expression is not present, a constant unity | |
986 | expression is returned. We don't return MATCH_ERROR until after | |
987 | the equals sign is seen. */ | |
988 | ||
989 | match | |
b251af97 | 990 | gfc_match_iterator (gfc_iterator *iter, int init_flag) |
6de9cd9a DN |
991 | { |
992 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
993 | gfc_expr *var, *e1, *e2, *e3; | |
994 | locus start; | |
995 | match m; | |
996 | ||
d3a9eea2 TB |
997 | e1 = e2 = e3 = NULL; |
998 | ||
b251af97 | 999 | /* Match the start of an iterator without affecting the symbol table. */ |
6de9cd9a | 1000 | |
63645982 | 1001 | start = gfc_current_locus; |
6de9cd9a | 1002 | m = gfc_match (" %n =", name); |
63645982 | 1003 | gfc_current_locus = start; |
6de9cd9a DN |
1004 | |
1005 | if (m != MATCH_YES) | |
1006 | return MATCH_NO; | |
1007 | ||
1008 | m = gfc_match_variable (&var, 0); | |
1009 | if (m != MATCH_YES) | |
1010 | return MATCH_NO; | |
1011 | ||
b2fd5373 HA |
1012 | if (var->symtree->n.sym->attr.dimension) |
1013 | { | |
1014 | gfc_error ("Loop variable at %C cannot be an array"); | |
1015 | goto cleanup; | |
1016 | } | |
1017 | ||
d3a9eea2 TB |
1018 | /* F2008, C617 & C565. */ |
1019 | if (var->symtree->n.sym->attr.codimension) | |
1020 | { | |
1021 | gfc_error ("Loop variable at %C cannot be a coarray"); | |
1022 | goto cleanup; | |
1023 | } | |
6de9cd9a DN |
1024 | |
1025 | if (var->ref != NULL) | |
1026 | { | |
1027 | gfc_error ("Loop variable at %C cannot be a sub-component"); | |
1028 | goto cleanup; | |
1029 | } | |
1030 | ||
d3a9eea2 TB |
1031 | gfc_match_char ('='); |
1032 | ||
9a3db5a3 PT |
1033 | var->symtree->n.sym->attr.implied_index = 1; |
1034 | ||
6de9cd9a DN |
1035 | m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1); |
1036 | if (m == MATCH_NO) | |
1037 | goto syntax; | |
1038 | if (m == MATCH_ERROR) | |
1039 | goto cleanup; | |
1040 | ||
1041 | if (gfc_match_char (',') != MATCH_YES) | |
1042 | goto syntax; | |
1043 | ||
1044 | m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2); | |
1045 | if (m == MATCH_NO) | |
1046 | goto syntax; | |
1047 | if (m == MATCH_ERROR) | |
1048 | goto cleanup; | |
1049 | ||
1050 | if (gfc_match_char (',') != MATCH_YES) | |
1051 | { | |
b7e75771 | 1052 | e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); |
6de9cd9a DN |
1053 | goto done; |
1054 | } | |
1055 | ||
1056 | m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3); | |
1057 | if (m == MATCH_ERROR) | |
1058 | goto cleanup; | |
1059 | if (m == MATCH_NO) | |
1060 | { | |
1061 | gfc_error ("Expected a step value in iterator at %C"); | |
1062 | goto cleanup; | |
1063 | } | |
1064 | ||
1065 | done: | |
1066 | iter->var = var; | |
1067 | iter->start = e1; | |
1068 | iter->end = e2; | |
1069 | iter->step = e3; | |
1070 | return MATCH_YES; | |
1071 | ||
1072 | syntax: | |
1073 | gfc_error ("Syntax error in iterator at %C"); | |
1074 | ||
1075 | cleanup: | |
1076 | gfc_free_expr (e1); | |
1077 | gfc_free_expr (e2); | |
1078 | gfc_free_expr (e3); | |
1079 | ||
1080 | return MATCH_ERROR; | |
1081 | } | |
1082 | ||
1083 | ||
1084 | /* Tries to match the next non-whitespace character on the input. | |
1085 | This subroutine does not return MATCH_ERROR. */ | |
1086 | ||
1087 | match | |
1088 | gfc_match_char (char c) | |
1089 | { | |
1090 | locus where; | |
1091 | ||
63645982 | 1092 | where = gfc_current_locus; |
6de9cd9a DN |
1093 | gfc_gobble_whitespace (); |
1094 | ||
8fc541d3 | 1095 | if (gfc_next_ascii_char () == c) |
6de9cd9a DN |
1096 | return MATCH_YES; |
1097 | ||
63645982 | 1098 | gfc_current_locus = where; |
6de9cd9a DN |
1099 | return MATCH_NO; |
1100 | } | |
1101 | ||
1102 | ||
1103 | /* General purpose matching subroutine. The target string is a | |
1104 | scanf-like format string in which spaces correspond to arbitrary | |
1105 | whitespace (including no whitespace), characters correspond to | |
1106 | themselves. The %-codes are: | |
1107 | ||
1108 | %% Literal percent sign | |
1109 | %e Expression, pointer to a pointer is set | |
1110 | %s Symbol, pointer to the symbol is set | |
1111 | %n Name, character buffer is set to name | |
1112 | %t Matches end of statement. | |
1113 | %o Matches an intrinsic operator, returned as an INTRINSIC enum. | |
1114 | %l Matches a statement label | |
1115 | %v Matches a variable expression (an lvalue) | |
1116 | % Matches a required space (in free form) and optional spaces. */ | |
1117 | ||
1118 | match | |
1119 | gfc_match (const char *target, ...) | |
1120 | { | |
1121 | gfc_st_label **label; | |
1122 | int matches, *ip; | |
1123 | locus old_loc; | |
1124 | va_list argp; | |
1125 | char c, *np; | |
1126 | match m, n; | |
1127 | void **vp; | |
1128 | const char *p; | |
1129 | ||
63645982 | 1130 | old_loc = gfc_current_locus; |
6de9cd9a DN |
1131 | va_start (argp, target); |
1132 | m = MATCH_NO; | |
1133 | matches = 0; | |
1134 | p = target; | |
1135 | ||
1136 | loop: | |
1137 | c = *p++; | |
1138 | switch (c) | |
1139 | { | |
1140 | case ' ': | |
1141 | gfc_gobble_whitespace (); | |
1142 | goto loop; | |
1143 | case '\0': | |
1144 | m = MATCH_YES; | |
1145 | break; | |
1146 | ||
1147 | case '%': | |
1148 | c = *p++; | |
1149 | switch (c) | |
1150 | { | |
1151 | case 'e': | |
1152 | vp = va_arg (argp, void **); | |
1153 | n = gfc_match_expr ((gfc_expr **) vp); | |
1154 | if (n != MATCH_YES) | |
1155 | { | |
1156 | m = n; | |
1157 | goto not_yes; | |
1158 | } | |
1159 | ||
1160 | matches++; | |
1161 | goto loop; | |
1162 | ||
1163 | case 'v': | |
1164 | vp = va_arg (argp, void **); | |
1165 | n = gfc_match_variable ((gfc_expr **) vp, 0); | |
1166 | if (n != MATCH_YES) | |
1167 | { | |
1168 | m = n; | |
1169 | goto not_yes; | |
1170 | } | |
1171 | ||
1172 | matches++; | |
1173 | goto loop; | |
1174 | ||
1175 | case 's': | |
1176 | vp = va_arg (argp, void **); | |
1177 | n = gfc_match_symbol ((gfc_symbol **) vp, 0); | |
1178 | if (n != MATCH_YES) | |
1179 | { | |
1180 | m = n; | |
1181 | goto not_yes; | |
1182 | } | |
1183 | ||
1184 | matches++; | |
1185 | goto loop; | |
1186 | ||
1187 | case 'n': | |
1188 | np = va_arg (argp, char *); | |
1189 | n = gfc_match_name (np); | |
1190 | if (n != MATCH_YES) | |
1191 | { | |
1192 | m = n; | |
1193 | goto not_yes; | |
1194 | } | |
1195 | ||
1196 | matches++; | |
1197 | goto loop; | |
1198 | ||
1199 | case 'l': | |
1200 | label = va_arg (argp, gfc_st_label **); | |
a34a91f0 | 1201 | n = gfc_match_st_label (label); |
6de9cd9a DN |
1202 | if (n != MATCH_YES) |
1203 | { | |
1204 | m = n; | |
1205 | goto not_yes; | |
1206 | } | |
1207 | ||
1208 | matches++; | |
1209 | goto loop; | |
1210 | ||
1211 | case 'o': | |
1212 | ip = va_arg (argp, int *); | |
1213 | n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip); | |
1214 | if (n != MATCH_YES) | |
1215 | { | |
1216 | m = n; | |
1217 | goto not_yes; | |
1218 | } | |
1219 | ||
1220 | matches++; | |
1221 | goto loop; | |
1222 | ||
1223 | case 't': | |
1224 | if (gfc_match_eos () != MATCH_YES) | |
1225 | { | |
1226 | m = MATCH_NO; | |
1227 | goto not_yes; | |
1228 | } | |
1229 | goto loop; | |
1230 | ||
1231 | case ' ': | |
1232 | if (gfc_match_space () == MATCH_YES) | |
1233 | goto loop; | |
1234 | m = MATCH_NO; | |
1235 | goto not_yes; | |
1236 | ||
1237 | case '%': | |
66e4ab31 | 1238 | break; /* Fall through to character matcher. */ |
6de9cd9a DN |
1239 | |
1240 | default: | |
1241 | gfc_internal_error ("gfc_match(): Bad match code %c", c); | |
1242 | } | |
65791f42 | 1243 | /* FALLTHRU */ |
6de9cd9a DN |
1244 | |
1245 | default: | |
befdf741 DK |
1246 | |
1247 | /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't | |
1248 | expect an upper case character here! */ | |
1249 | gcc_assert (TOLOWER (c) == c); | |
1250 | ||
8fc541d3 | 1251 | if (c == gfc_next_ascii_char ()) |
6de9cd9a DN |
1252 | goto loop; |
1253 | break; | |
1254 | } | |
1255 | ||
1256 | not_yes: | |
1257 | va_end (argp); | |
1258 | ||
1259 | if (m != MATCH_YES) | |
1260 | { | |
1261 | /* Clean up after a failed match. */ | |
63645982 | 1262 | gfc_current_locus = old_loc; |
6de9cd9a DN |
1263 | va_start (argp, target); |
1264 | ||
1265 | p = target; | |
1266 | for (; matches > 0; matches--) | |
1267 | { | |
1268 | while (*p++ != '%'); | |
1269 | ||
1270 | switch (*p++) | |
1271 | { | |
1272 | case '%': | |
1273 | matches++; | |
66e4ab31 | 1274 | break; /* Skip. */ |
6de9cd9a | 1275 | |
6de9cd9a DN |
1276 | /* Matches that don't have to be undone */ |
1277 | case 'o': | |
1278 | case 'l': | |
1279 | case 'n': | |
1280 | case 's': | |
b251af97 | 1281 | (void) va_arg (argp, void **); |
6de9cd9a DN |
1282 | break; |
1283 | ||
1284 | case 'e': | |
6de9cd9a | 1285 | case 'v': |
6de9cd9a | 1286 | vp = va_arg (argp, void **); |
ece3f663 | 1287 | gfc_free_expr ((struct gfc_expr *)*vp); |
6de9cd9a DN |
1288 | *vp = NULL; |
1289 | break; | |
1290 | } | |
1291 | } | |
1292 | ||
1293 | va_end (argp); | |
1294 | } | |
1295 | ||
1296 | return m; | |
1297 | } | |
1298 | ||
1299 | ||
1300 | /*********************** Statement level matching **********************/ | |
1301 | ||
1302 | /* Matches the start of a program unit, which is the program keyword | |
e08b5a75 | 1303 | followed by an obligatory symbol. */ |
6de9cd9a DN |
1304 | |
1305 | match | |
1306 | gfc_match_program (void) | |
1307 | { | |
1308 | gfc_symbol *sym; | |
1309 | match m; | |
1310 | ||
6de9cd9a DN |
1311 | m = gfc_match ("% %s%t", &sym); |
1312 | ||
1313 | if (m == MATCH_NO) | |
1314 | { | |
1315 | gfc_error ("Invalid form of PROGRAM statement at %C"); | |
1316 | m = MATCH_ERROR; | |
1317 | } | |
1318 | ||
1319 | if (m == MATCH_ERROR) | |
1320 | return m; | |
1321 | ||
524af0d6 | 1322 | if (!gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL)) |
6de9cd9a DN |
1323 | return MATCH_ERROR; |
1324 | ||
1325 | gfc_new_block = sym; | |
1326 | ||
1327 | return MATCH_YES; | |
1328 | } | |
1329 | ||
1330 | ||
1331 | /* Match a simple assignment statement. */ | |
1332 | ||
1333 | match | |
1334 | gfc_match_assignment (void) | |
1335 | { | |
1336 | gfc_expr *lvalue, *rvalue; | |
1337 | locus old_loc; | |
1338 | match m; | |
1339 | ||
63645982 | 1340 | old_loc = gfc_current_locus; |
6de9cd9a | 1341 | |
5056a350 | 1342 | lvalue = NULL; |
6de9cd9a DN |
1343 | m = gfc_match (" %v =", &lvalue); |
1344 | if (m != MATCH_YES) | |
c9583ed2 | 1345 | { |
5056a350 SK |
1346 | gfc_current_locus = old_loc; |
1347 | gfc_free_expr (lvalue); | |
1348 | return MATCH_NO; | |
c9583ed2 TS |
1349 | } |
1350 | ||
5056a350 | 1351 | rvalue = NULL; |
6de9cd9a DN |
1352 | m = gfc_match (" %e%t", &rvalue); |
1353 | if (m != MATCH_YES) | |
5056a350 SK |
1354 | { |
1355 | gfc_current_locus = old_loc; | |
1356 | gfc_free_expr (lvalue); | |
1357 | gfc_free_expr (rvalue); | |
1358 | return m; | |
1359 | } | |
6de9cd9a DN |
1360 | |
1361 | gfc_set_sym_referenced (lvalue->symtree->n.sym); | |
1362 | ||
1363 | new_st.op = EXEC_ASSIGN; | |
a513927a | 1364 | new_st.expr1 = lvalue; |
6de9cd9a DN |
1365 | new_st.expr2 = rvalue; |
1366 | ||
c9583ed2 TS |
1367 | gfc_check_do_variable (lvalue->symtree); |
1368 | ||
6de9cd9a | 1369 | return MATCH_YES; |
6de9cd9a DN |
1370 | } |
1371 | ||
1372 | ||
1373 | /* Match a pointer assignment statement. */ | |
1374 | ||
1375 | match | |
1376 | gfc_match_pointer_assignment (void) | |
1377 | { | |
1378 | gfc_expr *lvalue, *rvalue; | |
1379 | locus old_loc; | |
1380 | match m; | |
1381 | ||
63645982 | 1382 | old_loc = gfc_current_locus; |
6de9cd9a DN |
1383 | |
1384 | lvalue = rvalue = NULL; | |
837c4b78 | 1385 | gfc_matching_ptr_assignment = 0; |
8fb74da4 | 1386 | gfc_matching_procptr_assignment = 0; |
6de9cd9a DN |
1387 | |
1388 | m = gfc_match (" %v =>", &lvalue); | |
1389 | if (m != MATCH_YES) | |
1390 | { | |
1391 | m = MATCH_NO; | |
1392 | goto cleanup; | |
1393 | } | |
1394 | ||
713485cc | 1395 | if (lvalue->symtree->n.sym->attr.proc_pointer |
2a573572 | 1396 | || gfc_is_proc_ptr_comp (lvalue)) |
8fb74da4 | 1397 | gfc_matching_procptr_assignment = 1; |
837c4b78 JW |
1398 | else |
1399 | gfc_matching_ptr_assignment = 1; | |
8fb74da4 | 1400 | |
6de9cd9a | 1401 | m = gfc_match (" %e%t", &rvalue); |
837c4b78 | 1402 | gfc_matching_ptr_assignment = 0; |
8fb74da4 | 1403 | gfc_matching_procptr_assignment = 0; |
6de9cd9a DN |
1404 | if (m != MATCH_YES) |
1405 | goto cleanup; | |
1406 | ||
1407 | new_st.op = EXEC_POINTER_ASSIGN; | |
a513927a | 1408 | new_st.expr1 = lvalue; |
6de9cd9a DN |
1409 | new_st.expr2 = rvalue; |
1410 | ||
1411 | return MATCH_YES; | |
1412 | ||
1413 | cleanup: | |
63645982 | 1414 | gfc_current_locus = old_loc; |
6de9cd9a DN |
1415 | gfc_free_expr (lvalue); |
1416 | gfc_free_expr (rvalue); | |
1417 | return m; | |
1418 | } | |
1419 | ||
1420 | ||
43e1c5f7 | 1421 | /* We try to match an easy arithmetic IF statement. This only happens |
835d64ab FXC |
1422 | when just after having encountered a simple IF statement. This code |
1423 | is really duplicate with parts of the gfc_match_if code, but this is | |
1424 | *much* easier. */ | |
b251af97 | 1425 | |
f55e72ce | 1426 | static match |
835d64ab | 1427 | match_arithmetic_if (void) |
43e1c5f7 FXC |
1428 | { |
1429 | gfc_st_label *l1, *l2, *l3; | |
1430 | gfc_expr *expr; | |
1431 | match m; | |
1432 | ||
1433 | m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3); | |
1434 | if (m != MATCH_YES) | |
1435 | return m; | |
1436 | ||
524af0d6 JB |
1437 | if (!gfc_reference_st_label (l1, ST_LABEL_TARGET) |
1438 | || !gfc_reference_st_label (l2, ST_LABEL_TARGET) | |
1439 | || !gfc_reference_st_label (l3, ST_LABEL_TARGET)) | |
43e1c5f7 FXC |
1440 | { |
1441 | gfc_free_expr (expr); | |
1442 | return MATCH_ERROR; | |
1443 | } | |
1444 | ||
524af0d6 | 1445 | if (!gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF statement at %C")) |
51c3f0f6 FXC |
1446 | return MATCH_ERROR; |
1447 | ||
43e1c5f7 | 1448 | new_st.op = EXEC_ARITHMETIC_IF; |
a513927a | 1449 | new_st.expr1 = expr; |
79bd1948 | 1450 | new_st.label1 = l1; |
43e1c5f7 FXC |
1451 | new_st.label2 = l2; |
1452 | new_st.label3 = l3; | |
1453 | ||
1454 | return MATCH_YES; | |
1455 | } | |
1456 | ||
1457 | ||
6de9cd9a DN |
1458 | /* The IF statement is a bit of a pain. First of all, there are three |
1459 | forms of it, the simple IF, the IF that starts a block and the | |
1460 | arithmetic IF. | |
1461 | ||
1462 | There is a problem with the simple IF and that is the fact that we | |
1463 | only have a single level of undo information on symbols. What this | |
1464 | means is for a simple IF, we must re-match the whole IF statement | |
1465 | multiple times in order to guarantee that the symbol table ends up | |
1466 | in the proper state. */ | |
1467 | ||
c874ae73 TS |
1468 | static match match_simple_forall (void); |
1469 | static match match_simple_where (void); | |
1470 | ||
6de9cd9a | 1471 | match |
b251af97 | 1472 | gfc_match_if (gfc_statement *if_type) |
6de9cd9a DN |
1473 | { |
1474 | gfc_expr *expr; | |
1475 | gfc_st_label *l1, *l2, *l3; | |
f9b9fb82 | 1476 | locus old_loc, old_loc2; |
6de9cd9a DN |
1477 | gfc_code *p; |
1478 | match m, n; | |
1479 | ||
1480 | n = gfc_match_label (); | |
1481 | if (n == MATCH_ERROR) | |
1482 | return n; | |
1483 | ||
63645982 | 1484 | old_loc = gfc_current_locus; |
6de9cd9a DN |
1485 | |
1486 | m = gfc_match (" if ( %e", &expr); | |
1487 | if (m != MATCH_YES) | |
1488 | return m; | |
1489 | ||
f9b9fb82 JD |
1490 | old_loc2 = gfc_current_locus; |
1491 | gfc_current_locus = old_loc; | |
8b704316 | 1492 | |
f9b9fb82 JD |
1493 | if (gfc_match_parens () == MATCH_ERROR) |
1494 | return MATCH_ERROR; | |
1495 | ||
1496 | gfc_current_locus = old_loc2; | |
1497 | ||
6de9cd9a DN |
1498 | if (gfc_match_char (')') != MATCH_YES) |
1499 | { | |
1500 | gfc_error ("Syntax error in IF-expression at %C"); | |
1501 | gfc_free_expr (expr); | |
1502 | return MATCH_ERROR; | |
1503 | } | |
1504 | ||
1505 | m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3); | |
1506 | ||
1507 | if (m == MATCH_YES) | |
1508 | { | |
1509 | if (n == MATCH_YES) | |
1510 | { | |
b251af97 SK |
1511 | gfc_error ("Block label not appropriate for arithmetic IF " |
1512 | "statement at %C"); | |
6de9cd9a DN |
1513 | gfc_free_expr (expr); |
1514 | return MATCH_ERROR; | |
1515 | } | |
1516 | ||
524af0d6 JB |
1517 | if (!gfc_reference_st_label (l1, ST_LABEL_TARGET) |
1518 | || !gfc_reference_st_label (l2, ST_LABEL_TARGET) | |
1519 | || !gfc_reference_st_label (l3, ST_LABEL_TARGET)) | |
6de9cd9a | 1520 | { |
6de9cd9a DN |
1521 | gfc_free_expr (expr); |
1522 | return MATCH_ERROR; | |
1523 | } | |
8b704316 | 1524 | |
524af0d6 | 1525 | if (!gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF statement at %C")) |
b251af97 | 1526 | return MATCH_ERROR; |
6de9cd9a DN |
1527 | |
1528 | new_st.op = EXEC_ARITHMETIC_IF; | |
a513927a | 1529 | new_st.expr1 = expr; |
79bd1948 | 1530 | new_st.label1 = l1; |
6de9cd9a DN |
1531 | new_st.label2 = l2; |
1532 | new_st.label3 = l3; | |
1533 | ||
1534 | *if_type = ST_ARITHMETIC_IF; | |
1535 | return MATCH_YES; | |
1536 | } | |
1537 | ||
172b8799 | 1538 | if (gfc_match (" then%t") == MATCH_YES) |
6de9cd9a DN |
1539 | { |
1540 | new_st.op = EXEC_IF; | |
a513927a | 1541 | new_st.expr1 = expr; |
6de9cd9a DN |
1542 | *if_type = ST_IF_BLOCK; |
1543 | return MATCH_YES; | |
1544 | } | |
1545 | ||
1546 | if (n == MATCH_YES) | |
1547 | { | |
f9b9fb82 | 1548 | gfc_error ("Block label is not appropriate for IF statement at %C"); |
6de9cd9a DN |
1549 | gfc_free_expr (expr); |
1550 | return MATCH_ERROR; | |
1551 | } | |
1552 | ||
1553 | /* At this point the only thing left is a simple IF statement. At | |
1554 | this point, n has to be MATCH_NO, so we don't have to worry about | |
1555 | re-matching a block label. From what we've got so far, try | |
1556 | matching an assignment. */ | |
1557 | ||
1558 | *if_type = ST_SIMPLE_IF; | |
1559 | ||
1560 | m = gfc_match_assignment (); | |
1561 | if (m == MATCH_YES) | |
1562 | goto got_match; | |
1563 | ||
1564 | gfc_free_expr (expr); | |
1565 | gfc_undo_symbols (); | |
63645982 | 1566 | gfc_current_locus = old_loc; |
6de9cd9a | 1567 | |
5056a350 SK |
1568 | /* m can be MATCH_NO or MATCH_ERROR, here. For MATCH_ERROR, a mangled |
1569 | assignment was found. For MATCH_NO, continue to call the various | |
1570 | matchers. */ | |
17bbca74 SK |
1571 | if (m == MATCH_ERROR) |
1572 | return MATCH_ERROR; | |
1573 | ||
66e4ab31 | 1574 | gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */ |
6de9cd9a DN |
1575 | |
1576 | m = gfc_match_pointer_assignment (); | |
1577 | if (m == MATCH_YES) | |
1578 | goto got_match; | |
1579 | ||
1580 | gfc_free_expr (expr); | |
1581 | gfc_undo_symbols (); | |
63645982 | 1582 | gfc_current_locus = old_loc; |
6de9cd9a | 1583 | |
66e4ab31 | 1584 | gfc_match (" if ( %e ) ", &expr); /* Guaranteed to match. */ |
6de9cd9a DN |
1585 | |
1586 | /* Look at the next keyword to see which matcher to call. Matching | |
1587 | the keyword doesn't affect the symbol table, so we don't have to | |
1588 | restore between tries. */ | |
1589 | ||
1590 | #define match(string, subr, statement) \ | |
524af0d6 | 1591 | if (gfc_match (string) == MATCH_YES) { m = subr(); goto got_match; } |
6de9cd9a DN |
1592 | |
1593 | gfc_clear_error (); | |
1594 | ||
1595 | match ("allocate", gfc_match_allocate, ST_ALLOCATE) | |
5056a350 SK |
1596 | match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT) |
1597 | match ("backspace", gfc_match_backspace, ST_BACKSPACE) | |
1598 | match ("call", gfc_match_call, ST_CALL) | |
1599 | match ("close", gfc_match_close, ST_CLOSE) | |
1600 | match ("continue", gfc_match_continue, ST_CONTINUE) | |
1601 | match ("cycle", gfc_match_cycle, ST_CYCLE) | |
1602 | match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE) | |
1603 | match ("end file", gfc_match_endfile, ST_END_FILE) | |
d0a4a61c | 1604 | match ("error stop", gfc_match_error_stop, ST_ERROR_STOP) |
5df445a2 TB |
1605 | match ("event post", gfc_match_event_post, ST_EVENT_POST) |
1606 | match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT) | |
5056a350 | 1607 | match ("exit", gfc_match_exit, ST_EXIT) |
ef78bc3c | 1608 | match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE) |
5056a350 SK |
1609 | match ("flush", gfc_match_flush, ST_FLUSH) |
1610 | match ("forall", match_simple_forall, ST_FORALL) | |
1611 | match ("go to", gfc_match_goto, ST_GOTO) | |
1612 | match ("if", match_arithmetic_if, ST_ARITHMETIC_IF) | |
1613 | match ("inquire", gfc_match_inquire, ST_INQUIRE) | |
5493aa17 | 1614 | match ("lock", gfc_match_lock, ST_LOCK) |
5056a350 SK |
1615 | match ("nullify", gfc_match_nullify, ST_NULLIFY) |
1616 | match ("open", gfc_match_open, ST_OPEN) | |
1617 | match ("pause", gfc_match_pause, ST_NONE) | |
1618 | match ("print", gfc_match_print, ST_WRITE) | |
1619 | match ("read", gfc_match_read, ST_READ) | |
1620 | match ("return", gfc_match_return, ST_RETURN) | |
1621 | match ("rewind", gfc_match_rewind, ST_REWIND) | |
1622 | match ("stop", gfc_match_stop, ST_STOP) | |
6f0f0b2e | 1623 | match ("wait", gfc_match_wait, ST_WAIT) |
d0a4a61c TB |
1624 | match ("sync all", gfc_match_sync_all, ST_SYNC_CALL); |
1625 | match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); | |
1626 | match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); | |
5493aa17 | 1627 | match ("unlock", gfc_match_unlock, ST_UNLOCK) |
5056a350 SK |
1628 | match ("where", match_simple_where, ST_WHERE) |
1629 | match ("write", gfc_match_write, ST_WRITE) | |
1630 | ||
90051c26 FR |
1631 | if (flag_dec) |
1632 | match ("type", gfc_match_print, ST_WRITE) | |
1633 | ||
5056a350 | 1634 | /* The gfc_match_assignment() above may have returned a MATCH_NO |
8b704316 | 1635 | where the assignment was to a named constant. Check that |
5056a350 SK |
1636 | special case here. */ |
1637 | m = gfc_match_assignment (); | |
1638 | if (m == MATCH_NO) | |
1639 | { | |
1640 | gfc_error ("Cannot assign to a named constant at %C"); | |
1641 | gfc_free_expr (expr); | |
1642 | gfc_undo_symbols (); | |
1643 | gfc_current_locus = old_loc; | |
1644 | return MATCH_ERROR; | |
1645 | } | |
6de9cd9a DN |
1646 | |
1647 | /* All else has failed, so give up. See if any of the matchers has | |
1648 | stored an error message of some sort. */ | |
b5a9fd3e | 1649 | if (!gfc_error_check ()) |
6de9cd9a DN |
1650 | gfc_error ("Unclassifiable statement in IF-clause at %C"); |
1651 | ||
1652 | gfc_free_expr (expr); | |
1653 | return MATCH_ERROR; | |
1654 | ||
1655 | got_match: | |
1656 | if (m == MATCH_NO) | |
1657 | gfc_error ("Syntax error in IF-clause at %C"); | |
1658 | if (m != MATCH_YES) | |
1659 | { | |
1660 | gfc_free_expr (expr); | |
1661 | return MATCH_ERROR; | |
1662 | } | |
1663 | ||
1664 | /* At this point, we've matched the single IF and the action clause | |
1665 | is in new_st. Rearrange things so that the IF statement appears | |
1666 | in new_st. */ | |
1667 | ||
11e5274a JW |
1668 | p = gfc_get_code (EXEC_IF); |
1669 | p->next = XCNEW (gfc_code); | |
6de9cd9a | 1670 | *p->next = new_st; |
63645982 | 1671 | p->next->loc = gfc_current_locus; |
6de9cd9a | 1672 | |
a513927a | 1673 | p->expr1 = expr; |
6de9cd9a DN |
1674 | |
1675 | gfc_clear_new_st (); | |
1676 | ||
1677 | new_st.op = EXEC_IF; | |
1678 | new_st.block = p; | |
1679 | ||
1680 | return MATCH_YES; | |
1681 | } | |
1682 | ||
1683 | #undef match | |
1684 | ||
1685 | ||
1686 | /* Match an ELSE statement. */ | |
1687 | ||
1688 | match | |
1689 | gfc_match_else (void) | |
1690 | { | |
1691 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
1692 | ||
1693 | if (gfc_match_eos () == MATCH_YES) | |
1694 | return MATCH_YES; | |
1695 | ||
1696 | if (gfc_match_name (name) != MATCH_YES | |
1697 | || gfc_current_block () == NULL | |
1698 | || gfc_match_eos () != MATCH_YES) | |
1699 | { | |
1700 | gfc_error ("Unexpected junk after ELSE statement at %C"); | |
1701 | return MATCH_ERROR; | |
1702 | } | |
1703 | ||
1704 | if (strcmp (name, gfc_current_block ()->name) != 0) | |
1705 | { | |
a4d9b221 | 1706 | gfc_error ("Label %qs at %C doesn't match IF label %qs", |
6de9cd9a DN |
1707 | name, gfc_current_block ()->name); |
1708 | return MATCH_ERROR; | |
1709 | } | |
1710 | ||
1711 | return MATCH_YES; | |
1712 | } | |
1713 | ||
1714 | ||
1715 | /* Match an ELSE IF statement. */ | |
1716 | ||
1717 | match | |
1718 | gfc_match_elseif (void) | |
1719 | { | |
1720 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
1721 | gfc_expr *expr; | |
1722 | match m; | |
1723 | ||
1724 | m = gfc_match (" ( %e ) then", &expr); | |
1725 | if (m != MATCH_YES) | |
1726 | return m; | |
1727 | ||
1728 | if (gfc_match_eos () == MATCH_YES) | |
1729 | goto done; | |
1730 | ||
1731 | if (gfc_match_name (name) != MATCH_YES | |
1732 | || gfc_current_block () == NULL | |
1733 | || gfc_match_eos () != MATCH_YES) | |
1734 | { | |
1735 | gfc_error ("Unexpected junk after ELSE IF statement at %C"); | |
1736 | goto cleanup; | |
1737 | } | |
1738 | ||
1739 | if (strcmp (name, gfc_current_block ()->name) != 0) | |
1740 | { | |
a4d9b221 | 1741 | gfc_error ("Label %qs at %C doesn't match IF label %qs", |
6de9cd9a DN |
1742 | name, gfc_current_block ()->name); |
1743 | goto cleanup; | |
1744 | } | |
1745 | ||
1746 | done: | |
1747 | new_st.op = EXEC_IF; | |
a513927a | 1748 | new_st.expr1 = expr; |
6de9cd9a DN |
1749 | return MATCH_YES; |
1750 | ||
1751 | cleanup: | |
1752 | gfc_free_expr (expr); | |
1753 | return MATCH_ERROR; | |
1754 | } | |
1755 | ||
1756 | ||
1757 | /* Free a gfc_iterator structure. */ | |
1758 | ||
1759 | void | |
b251af97 | 1760 | gfc_free_iterator (gfc_iterator *iter, int flag) |
6de9cd9a | 1761 | { |
66e4ab31 | 1762 | |
6de9cd9a DN |
1763 | if (iter == NULL) |
1764 | return; | |
1765 | ||
1766 | gfc_free_expr (iter->var); | |
1767 | gfc_free_expr (iter->start); | |
1768 | gfc_free_expr (iter->end); | |
1769 | gfc_free_expr (iter->step); | |
1770 | ||
1771 | if (flag) | |
cede9502 | 1772 | free (iter); |
6de9cd9a DN |
1773 | } |
1774 | ||
1775 | ||
d0a4a61c TB |
1776 | /* Match a CRITICAL statement. */ |
1777 | match | |
1778 | gfc_match_critical (void) | |
1779 | { | |
1780 | gfc_st_label *label = NULL; | |
1781 | ||
1782 | if (gfc_match_label () == MATCH_ERROR) | |
1783 | return MATCH_ERROR; | |
1784 | ||
1785 | if (gfc_match (" critical") != MATCH_YES) | |
1786 | return MATCH_NO; | |
1787 | ||
1788 | if (gfc_match_st_label (&label) == MATCH_ERROR) | |
1789 | return MATCH_ERROR; | |
1790 | ||
1791 | if (gfc_match_eos () != MATCH_YES) | |
1792 | { | |
1793 | gfc_syntax_error (ST_CRITICAL); | |
1794 | return MATCH_ERROR; | |
1795 | } | |
1796 | ||
1797 | if (gfc_pure (NULL)) | |
1798 | { | |
1799 | gfc_error ("Image control statement CRITICAL at %C in PURE procedure"); | |
1800 | return MATCH_ERROR; | |
1801 | } | |
1802 | ||
524af0d6 | 1803 | if (gfc_find_state (COMP_DO_CONCURRENT)) |
8c6a85e3 TB |
1804 | { |
1805 | gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT " | |
1806 | "block"); | |
1807 | return MATCH_ERROR; | |
1808 | } | |
1809 | ||
ccd7751b | 1810 | gfc_unset_implicit_pure (NULL); |
f1f39033 | 1811 | |
524af0d6 | 1812 | if (!gfc_notify_std (GFC_STD_F2008, "CRITICAL statement at %C")) |
d0a4a61c TB |
1813 | return MATCH_ERROR; |
1814 | ||
f19626cf | 1815 | if (flag_coarray == GFC_FCOARRAY_NONE) |
f4d1d50a | 1816 | { |
ddc05d11 TB |
1817 | gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to " |
1818 | "enable"); | |
f4d1d50a TB |
1819 | return MATCH_ERROR; |
1820 | } | |
1821 | ||
524af0d6 | 1822 | if (gfc_find_state (COMP_CRITICAL)) |
d0a4a61c TB |
1823 | { |
1824 | gfc_error ("Nested CRITICAL block at %C"); | |
1825 | return MATCH_ERROR; | |
1826 | } | |
1827 | ||
1828 | new_st.op = EXEC_CRITICAL; | |
1829 | ||
1830 | if (label != NULL | |
524af0d6 | 1831 | && !gfc_reference_st_label (label, ST_LABEL_TARGET)) |
d0a4a61c TB |
1832 | return MATCH_ERROR; |
1833 | ||
1834 | return MATCH_YES; | |
1835 | } | |
1836 | ||
1837 | ||
9abe5e56 DK |
1838 | /* Match a BLOCK statement. */ |
1839 | ||
1840 | match | |
1841 | gfc_match_block (void) | |
1842 | { | |
1843 | match m; | |
1844 | ||
1845 | if (gfc_match_label () == MATCH_ERROR) | |
1846 | return MATCH_ERROR; | |
1847 | ||
1848 | if (gfc_match (" block") != MATCH_YES) | |
1849 | return MATCH_NO; | |
1850 | ||
1851 | /* For this to be a correct BLOCK statement, the line must end now. */ | |
1852 | m = gfc_match_eos (); | |
1853 | if (m == MATCH_ERROR) | |
1854 | return MATCH_ERROR; | |
1855 | if (m == MATCH_NO) | |
1856 | return MATCH_NO; | |
1857 | ||
1858 | return MATCH_YES; | |
1859 | } | |
1860 | ||
1861 | ||
03af1e4c DK |
1862 | /* Match an ASSOCIATE statement. */ |
1863 | ||
1864 | match | |
1865 | gfc_match_associate (void) | |
1866 | { | |
1867 | if (gfc_match_label () == MATCH_ERROR) | |
1868 | return MATCH_ERROR; | |
1869 | ||
1870 | if (gfc_match (" associate") != MATCH_YES) | |
1871 | return MATCH_NO; | |
1872 | ||
1873 | /* Match the association list. */ | |
1874 | if (gfc_match_char ('(') != MATCH_YES) | |
1875 | { | |
1876 | gfc_error ("Expected association list at %C"); | |
1877 | return MATCH_ERROR; | |
1878 | } | |
1879 | new_st.ext.block.assoc = NULL; | |
1880 | while (true) | |
1881 | { | |
1882 | gfc_association_list* newAssoc = gfc_get_association_list (); | |
1883 | gfc_association_list* a; | |
1884 | ||
1885 | /* Match the next association. */ | |
1886 | if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target) | |
1887 | != MATCH_YES) | |
1888 | { | |
b89a63b9 PT |
1889 | /* Have another go, allowing for procedure pointer selectors. */ |
1890 | gfc_matching_procptr_assignment = 1; | |
1891 | if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target) | |
1892 | != MATCH_YES) | |
1893 | { | |
1894 | gfc_error ("Expected association at %C"); | |
1895 | goto assocListError; | |
1896 | } | |
1897 | gfc_matching_procptr_assignment = 0; | |
03af1e4c | 1898 | } |
571d54de | 1899 | newAssoc->where = gfc_current_locus; |
03af1e4c DK |
1900 | |
1901 | /* Check that the current name is not yet in the list. */ | |
1902 | for (a = new_st.ext.block.assoc; a; a = a->next) | |
1903 | if (!strcmp (a->name, newAssoc->name)) | |
1904 | { | |
a4d9b221 | 1905 | gfc_error ("Duplicate name %qs in association at %C", |
03af1e4c DK |
1906 | newAssoc->name); |
1907 | goto assocListError; | |
1908 | } | |
1909 | ||
1910 | /* The target expression must not be coindexed. */ | |
1911 | if (gfc_is_coindexed (newAssoc->target)) | |
1912 | { | |
1913 | gfc_error ("Association target at %C must not be coindexed"); | |
1914 | goto assocListError; | |
1915 | } | |
1916 | ||
571d54de DK |
1917 | /* The `variable' field is left blank for now; because the target is not |
1918 | yet resolved, we can't use gfc_has_vector_subscript to determine it | |
8c91ab34 | 1919 | for now. This is set during resolution. */ |
03af1e4c DK |
1920 | |
1921 | /* Put it into the list. */ | |
1922 | newAssoc->next = new_st.ext.block.assoc; | |
1923 | new_st.ext.block.assoc = newAssoc; | |
1924 | ||
1925 | /* Try next one or end if closing parenthesis is found. */ | |
1926 | gfc_gobble_whitespace (); | |
1927 | if (gfc_peek_char () == ')') | |
1928 | break; | |
1929 | if (gfc_match_char (',') != MATCH_YES) | |
1930 | { | |
a4d9b221 | 1931 | gfc_error ("Expected %<)%> or %<,%> at %C"); |
03af1e4c DK |
1932 | return MATCH_ERROR; |
1933 | } | |
1934 | ||
1935 | continue; | |
1936 | ||
1937 | assocListError: | |
cede9502 | 1938 | free (newAssoc); |
03af1e4c DK |
1939 | goto error; |
1940 | } | |
1941 | if (gfc_match_char (')') != MATCH_YES) | |
1942 | { | |
1943 | /* This should never happen as we peek above. */ | |
1944 | gcc_unreachable (); | |
1945 | } | |
1946 | ||
1947 | if (gfc_match_eos () != MATCH_YES) | |
1948 | { | |
1949 | gfc_error ("Junk after ASSOCIATE statement at %C"); | |
1950 | goto error; | |
1951 | } | |
1952 | ||
1953 | return MATCH_YES; | |
1954 | ||
1955 | error: | |
1956 | gfc_free_association_list (new_st.ext.block.assoc); | |
1957 | return MATCH_ERROR; | |
1958 | } | |
1959 | ||
1960 | ||
8c6a85e3 TB |
1961 | /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of |
1962 | an accessible derived type. */ | |
6de9cd9a | 1963 | |
8c6a85e3 TB |
1964 | static match |
1965 | match_derived_type_spec (gfc_typespec *ts) | |
6de9cd9a | 1966 | { |
8c6a85e3 | 1967 | char name[GFC_MAX_SYMBOL_LEN + 1]; |
8b704316 | 1968 | locus old_locus; |
5bab4c96 PT |
1969 | gfc_symbol *derived, *der_type; |
1970 | match m = MATCH_YES; | |
1971 | gfc_actual_arglist *decl_type_param_list = NULL; | |
1972 | bool is_pdt_template = false; | |
6de9cd9a | 1973 | |
8c6a85e3 | 1974 | old_locus = gfc_current_locus; |
6de9cd9a | 1975 | |
8c6a85e3 TB |
1976 | if (gfc_match ("%n", name) != MATCH_YES) |
1977 | { | |
1978 | gfc_current_locus = old_locus; | |
1979 | return MATCH_NO; | |
1980 | } | |
6de9cd9a | 1981 | |
8c6a85e3 | 1982 | gfc_find_symbol (name, NULL, 1, &derived); |
6de9cd9a | 1983 | |
5bab4c96 PT |
1984 | /* Match the PDT spec list, if there. */ |
1985 | if (derived && derived->attr.flavor == FL_PROCEDURE) | |
1986 | { | |
1987 | gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &der_type); | |
1988 | is_pdt_template = der_type | |
1989 | && der_type->attr.flavor == FL_DERIVED | |
1990 | && der_type->attr.pdt_template; | |
1991 | } | |
1992 | ||
1993 | if (is_pdt_template) | |
1994 | m = gfc_match_actual_arglist (1, &decl_type_param_list, true); | |
1995 | ||
1996 | if (m == MATCH_ERROR) | |
1997 | { | |
1998 | gfc_free_actual_arglist (decl_type_param_list); | |
1999 | return m; | |
2000 | } | |
2001 | ||
c3f34952 TB |
2002 | if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic) |
2003 | derived = gfc_find_dt_in_generic (derived); | |
2004 | ||
5bab4c96 PT |
2005 | /* If this is a PDT, find the specific instance. */ |
2006 | if (m == MATCH_YES && is_pdt_template) | |
2007 | { | |
2008 | gfc_namespace *old_ns; | |
2009 | ||
2010 | old_ns = gfc_current_ns; | |
2011 | while (gfc_current_ns && gfc_current_ns->parent) | |
2012 | gfc_current_ns = gfc_current_ns->parent; | |
2013 | ||
2014 | if (type_param_spec_list) | |
2015 | gfc_free_actual_arglist (type_param_spec_list); | |
2016 | m = gfc_get_pdt_instance (decl_type_param_list, &der_type, | |
2017 | &type_param_spec_list); | |
2018 | gfc_free_actual_arglist (decl_type_param_list); | |
2019 | ||
2020 | if (m != MATCH_YES) | |
2021 | return m; | |
2022 | derived = der_type; | |
2023 | gcc_assert (!derived->attr.pdt_template && derived->attr.pdt_type); | |
2024 | gfc_set_sym_referenced (derived); | |
2025 | ||
2026 | gfc_current_ns = old_ns; | |
2027 | } | |
2028 | ||
8c6a85e3 TB |
2029 | if (derived && derived->attr.flavor == FL_DERIVED) |
2030 | { | |
2031 | ts->type = BT_DERIVED; | |
2032 | ts->u.derived = derived; | |
2033 | return MATCH_YES; | |
2034 | } | |
6de9cd9a | 2035 | |
8b704316 | 2036 | gfc_current_locus = old_locus; |
8c6a85e3 TB |
2037 | return MATCH_NO; |
2038 | } | |
9b089e05 | 2039 | |
6de9cd9a | 2040 | |
8c6a85e3 TB |
2041 | /* Match a Fortran 2003 type-spec (F03:R401). This is similar to |
2042 | gfc_match_decl_type_spec() from decl.c, with the following exceptions: | |
2043 | It only includes the intrinsic types from the Fortran 2003 standard | |
2044 | (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally, | |
2045 | the implicit_flag is not needed, so it was removed. Derived types are | |
2046 | identified by their name alone. */ | |
2047 | ||
894460a7 TB |
2048 | match |
2049 | gfc_match_type_spec (gfc_typespec *ts) | |
8c6a85e3 TB |
2050 | { |
2051 | match m; | |
2052 | locus old_locus; | |
87c9fca5 | 2053 | char name[GFC_MAX_SYMBOL_LEN + 1]; |
8c6a85e3 TB |
2054 | |
2055 | gfc_clear_ts (ts); | |
2056 | gfc_gobble_whitespace (); | |
2057 | old_locus = gfc_current_locus; | |
5bab4c96 | 2058 | type_param_spec_list = NULL; |
8c6a85e3 TB |
2059 | |
2060 | if (match_derived_type_spec (ts) == MATCH_YES) | |
6de9cd9a | 2061 | { |
8c6a85e3 TB |
2062 | /* Enforce F03:C401. */ |
2063 | if (ts->u.derived->attr.abstract) | |
2064 | { | |
a4d9b221 | 2065 | gfc_error ("Derived type %qs at %L may not be ABSTRACT", |
8c6a85e3 TB |
2066 | ts->u.derived->name, &old_locus); |
2067 | return MATCH_ERROR; | |
2068 | } | |
2069 | return MATCH_YES; | |
6de9cd9a DN |
2070 | } |
2071 | ||
8c6a85e3 TB |
2072 | if (gfc_match ("integer") == MATCH_YES) |
2073 | { | |
2074 | ts->type = BT_INTEGER; | |
2075 | ts->kind = gfc_default_integer_kind; | |
2076 | goto kind_selector; | |
2077 | } | |
6de9cd9a | 2078 | |
8c6a85e3 | 2079 | if (gfc_match ("double precision") == MATCH_YES) |
6de9cd9a | 2080 | { |
8c6a85e3 TB |
2081 | ts->type = BT_REAL; |
2082 | ts->kind = gfc_default_double_kind; | |
2083 | return MATCH_YES; | |
6de9cd9a DN |
2084 | } |
2085 | ||
8c6a85e3 TB |
2086 | if (gfc_match ("complex") == MATCH_YES) |
2087 | { | |
2088 | ts->type = BT_COMPLEX; | |
2089 | ts->kind = gfc_default_complex_kind; | |
2090 | goto kind_selector; | |
2091 | } | |
6de9cd9a | 2092 | |
8c6a85e3 TB |
2093 | if (gfc_match ("character") == MATCH_YES) |
2094 | { | |
2095 | ts->type = BT_CHARACTER; | |
6de9cd9a | 2096 | |
8c6a85e3 | 2097 | m = gfc_match_char_spec (ts); |
6de9cd9a | 2098 | |
8c6a85e3 TB |
2099 | if (m == MATCH_NO) |
2100 | m = MATCH_YES; | |
6de9cd9a | 2101 | |
8c6a85e3 TB |
2102 | return m; |
2103 | } | |
c9583ed2 | 2104 | |
8c6a85e3 | 2105 | if (gfc_match ("logical") == MATCH_YES) |
6de9cd9a | 2106 | { |
8c6a85e3 TB |
2107 | ts->type = BT_LOGICAL; |
2108 | ts->kind = gfc_default_logical_kind; | |
2109 | goto kind_selector; | |
6de9cd9a DN |
2110 | } |
2111 | ||
87c9fca5 SK |
2112 | /* REAL is a real pain because it can be a type, intrinsic subprogram, |
2113 | or list item in a type-list of an OpenMP reduction clause. Need to | |
2114 | differentiate REAL([KIND]=scalar-int-initialization-expr) from | |
2115 | REAL(A,[KIND]) and REAL(KIND,A). */ | |
2116 | ||
2117 | m = gfc_match (" %n", name); | |
2118 | if (m == MATCH_YES && strcmp (name, "real") == 0) | |
2119 | { | |
2120 | char c; | |
2121 | gfc_expr *e; | |
2122 | locus where; | |
2123 | ||
2124 | ts->type = BT_REAL; | |
2125 | ts->kind = gfc_default_real_kind; | |
2126 | ||
2127 | gfc_gobble_whitespace (); | |
2128 | ||
2129 | /* Prevent REAL*4, etc. */ | |
2130 | c = gfc_peek_ascii_char (); | |
2131 | if (c == '*') | |
2132 | { | |
2133 | gfc_error ("Invalid type-spec at %C"); | |
2134 | return MATCH_ERROR; | |
2135 | } | |
2136 | ||
2137 | /* Found leading colon in REAL::, a trailing ')' in for example | |
2138 | TYPE IS (REAL), or REAL, for an OpenMP list-item. */ | |
2139 | if (c == ':' || c == ')' || (flag_openmp && c == ',')) | |
2140 | return MATCH_YES; | |
2141 | ||
2142 | /* Found something other than the opening '(' in REAL(... */ | |
2143 | if (c != '(') | |
2144 | return MATCH_NO; | |
2145 | else | |
2146 | gfc_next_char (); /* Burn the '('. */ | |
2147 | ||
2148 | /* Look for the optional KIND=. */ | |
2149 | where = gfc_current_locus; | |
2150 | m = gfc_match ("%n", name); | |
2151 | if (m == MATCH_YES) | |
2152 | { | |
2153 | gfc_gobble_whitespace (); | |
2154 | c = gfc_next_char (); | |
2155 | if (c == '=') | |
2156 | { | |
2157 | if (strcmp(name, "a") == 0) | |
2158 | return MATCH_NO; | |
2159 | else if (strcmp(name, "kind") == 0) | |
2160 | goto found; | |
2161 | else | |
2162 | return MATCH_ERROR; | |
2163 | } | |
2164 | else | |
2165 | gfc_current_locus = where; | |
2166 | } | |
2167 | else | |
2168 | gfc_current_locus = where; | |
2169 | ||
2170 | found: | |
2171 | ||
2172 | m = gfc_match_init_expr (&e); | |
2173 | if (m == MATCH_NO || m == MATCH_ERROR) | |
2174 | return MATCH_NO; | |
2175 | ||
2176 | /* If a comma appears, it is an intrinsic subprogram. */ | |
2177 | gfc_gobble_whitespace (); | |
2178 | c = gfc_peek_ascii_char (); | |
2179 | if (c == ',') | |
2180 | { | |
2181 | gfc_free_expr (e); | |
2182 | return MATCH_NO; | |
2183 | } | |
2184 | ||
2185 | /* If ')' appears, we have REAL(initialization-expr), here check for | |
2186 | a scalar integer initialization-expr and valid kind parameter. */ | |
2187 | if (c == ')') | |
2188 | { | |
2189 | if (e->ts.type != BT_INTEGER || e->rank > 0) | |
2190 | { | |
2191 | gfc_free_expr (e); | |
2192 | return MATCH_NO; | |
2193 | } | |
2194 | ||
2195 | gfc_next_char (); /* Burn the ')'. */ | |
2196 | ts->kind = (int) mpz_get_si (e->value.integer); | |
2197 | if (gfc_validate_kind (BT_REAL, ts->kind , true) == -1) | |
2198 | { | |
2199 | gfc_error ("Invalid type-spec at %C"); | |
2200 | return MATCH_ERROR; | |
2201 | } | |
2202 | ||
2203 | gfc_free_expr (e); | |
2204 | ||
2205 | return MATCH_YES; | |
2206 | } | |
2207 | } | |
2208 | ||
8c6a85e3 TB |
2209 | /* If a type is not matched, simply return MATCH_NO. */ |
2210 | gfc_current_locus = old_locus; | |
2211 | return MATCH_NO; | |
6de9cd9a | 2212 | |
8c6a85e3 | 2213 | kind_selector: |
6de9cd9a | 2214 | |
8c6a85e3 | 2215 | gfc_gobble_whitespace (); |
87c9fca5 SK |
2216 | |
2217 | /* This prevents INTEGER*4, etc. */ | |
8c6a85e3 | 2218 | if (gfc_peek_ascii_char () == '*') |
6de9cd9a | 2219 | { |
8c6a85e3 TB |
2220 | gfc_error ("Invalid type-spec at %C"); |
2221 | return MATCH_ERROR; | |
6de9cd9a DN |
2222 | } |
2223 | ||
8c6a85e3 | 2224 | m = gfc_match_kind_spec (ts, false); |
6de9cd9a | 2225 | |
87c9fca5 | 2226 | /* No kind specifier found. */ |
8c6a85e3 | 2227 | if (m == MATCH_NO) |
87c9fca5 | 2228 | m = MATCH_YES; |
8d48826b | 2229 | |
8c6a85e3 | 2230 | return m; |
6de9cd9a DN |
2231 | } |
2232 | ||
2233 | ||
8c6a85e3 | 2234 | /******************** FORALL subroutines ********************/ |
6de9cd9a | 2235 | |
8c6a85e3 TB |
2236 | /* Free a list of FORALL iterators. */ |
2237 | ||
2238 | void | |
2239 | gfc_free_forall_iterator (gfc_forall_iterator *iter) | |
6de9cd9a | 2240 | { |
8c6a85e3 | 2241 | gfc_forall_iterator *next; |
6de9cd9a | 2242 | |
8c6a85e3 | 2243 | while (iter) |
6de9cd9a | 2244 | { |
8c6a85e3 TB |
2245 | next = iter->next; |
2246 | gfc_free_expr (iter->var); | |
2247 | gfc_free_expr (iter->start); | |
2248 | gfc_free_expr (iter->end); | |
2249 | gfc_free_expr (iter->stride); | |
2250 | free (iter); | |
2251 | iter = next; | |
2252 | } | |
2253 | } | |
61b644c2 | 2254 | |
6de9cd9a | 2255 | |
8c6a85e3 | 2256 | /* Match an iterator as part of a FORALL statement. The format is: |
61b644c2 | 2257 | |
8c6a85e3 | 2258 | <var> = <start>:<end>[:<stride>] |
6de9cd9a | 2259 | |
8c6a85e3 TB |
2260 | On MATCH_NO, the caller tests for the possibility that there is a |
2261 | scalar mask expression. */ | |
6de9cd9a | 2262 | |
8c6a85e3 TB |
2263 | static match |
2264 | match_forall_iterator (gfc_forall_iterator **result) | |
2265 | { | |
2266 | gfc_forall_iterator *iter; | |
2267 | locus where; | |
2268 | match m; | |
6de9cd9a | 2269 | |
8c6a85e3 TB |
2270 | where = gfc_current_locus; |
2271 | iter = XCNEW (gfc_forall_iterator); | |
6de9cd9a | 2272 | |
8c6a85e3 TB |
2273 | m = gfc_match_expr (&iter->var); |
2274 | if (m != MATCH_YES) | |
2275 | goto cleanup; | |
2276 | ||
2277 | if (gfc_match_char ('=') != MATCH_YES | |
2278 | || iter->var->expr_type != EXPR_VARIABLE) | |
e5ca9693 | 2279 | { |
8c6a85e3 TB |
2280 | m = MATCH_NO; |
2281 | goto cleanup; | |
2282 | } | |
e5ca9693 | 2283 | |
8c6a85e3 TB |
2284 | m = gfc_match_expr (&iter->start); |
2285 | if (m != MATCH_YES) | |
2286 | goto cleanup; | |
e5ca9693 | 2287 | |
8c6a85e3 TB |
2288 | if (gfc_match_char (':') != MATCH_YES) |
2289 | goto syntax; | |
e5ca9693 | 2290 | |
8c6a85e3 TB |
2291 | m = gfc_match_expr (&iter->end); |
2292 | if (m == MATCH_NO) | |
2293 | goto syntax; | |
2294 | if (m == MATCH_ERROR) | |
2295 | goto cleanup; | |
84fa59a7 | 2296 | |
8c6a85e3 TB |
2297 | if (gfc_match_char (':') == MATCH_NO) |
2298 | iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); | |
2299 | else | |
6c7a4dfd | 2300 | { |
8c6a85e3 TB |
2301 | m = gfc_match_expr (&iter->stride); |
2302 | if (m == MATCH_NO) | |
2303 | goto syntax; | |
2304 | if (m == MATCH_ERROR) | |
2305 | goto cleanup; | |
6c7a4dfd JJ |
2306 | } |
2307 | ||
8c6a85e3 TB |
2308 | /* Mark the iteration variable's symbol as used as a FORALL index. */ |
2309 | iter->var->symtree->n.sym->forall_index = true; | |
6de9cd9a | 2310 | |
8c6a85e3 | 2311 | *result = iter; |
6de9cd9a | 2312 | return MATCH_YES; |
6de9cd9a | 2313 | |
8c6a85e3 TB |
2314 | syntax: |
2315 | gfc_error ("Syntax error in FORALL iterator at %C"); | |
2316 | m = MATCH_ERROR; | |
6de9cd9a | 2317 | |
8c6a85e3 | 2318 | cleanup: |
6de9cd9a | 2319 | |
8c6a85e3 TB |
2320 | gfc_current_locus = where; |
2321 | gfc_free_forall_iterator (iter); | |
2322 | return m; | |
6de9cd9a DN |
2323 | } |
2324 | ||
2325 | ||
8c6a85e3 | 2326 | /* Match the header of a FORALL statement. */ |
6de9cd9a DN |
2327 | |
2328 | static match | |
8c6a85e3 | 2329 | match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) |
6de9cd9a | 2330 | { |
8c6a85e3 TB |
2331 | gfc_forall_iterator *head, *tail, *new_iter; |
2332 | gfc_expr *msk; | |
6de9cd9a DN |
2333 | match m; |
2334 | ||
8c6a85e3 | 2335 | gfc_gobble_whitespace (); |
6de9cd9a | 2336 | |
8c6a85e3 TB |
2337 | head = tail = NULL; |
2338 | msk = NULL; | |
6de9cd9a | 2339 | |
8c6a85e3 TB |
2340 | if (gfc_match_char ('(') != MATCH_YES) |
2341 | return MATCH_NO; | |
6d1b0f92 | 2342 | |
8c6a85e3 TB |
2343 | m = match_forall_iterator (&new_iter); |
2344 | if (m == MATCH_ERROR) | |
2345 | goto cleanup; | |
2346 | if (m == MATCH_NO) | |
2347 | goto syntax; | |
6de9cd9a | 2348 | |
8c6a85e3 | 2349 | head = tail = new_iter; |
f1f39033 | 2350 | |
8c6a85e3 | 2351 | for (;;) |
d0a4a61c | 2352 | { |
8c6a85e3 TB |
2353 | if (gfc_match_char (',') != MATCH_YES) |
2354 | break; | |
d0a4a61c | 2355 | |
8c6a85e3 TB |
2356 | m = match_forall_iterator (&new_iter); |
2357 | if (m == MATCH_ERROR) | |
2358 | goto cleanup; | |
5d2d72cb | 2359 | |
8c6a85e3 | 2360 | if (m == MATCH_YES) |
5d2d72cb | 2361 | { |
8c6a85e3 TB |
2362 | tail->next = new_iter; |
2363 | tail = new_iter; | |
2364 | continue; | |
6d1b0f92 JD |
2365 | } |
2366 | ||
8c6a85e3 | 2367 | /* Have to have a mask expression. */ |
6d1b0f92 | 2368 | |
8c6a85e3 TB |
2369 | m = gfc_match_expr (&msk); |
2370 | if (m == MATCH_NO) | |
2371 | goto syntax; | |
2372 | if (m == MATCH_ERROR) | |
2373 | goto cleanup; | |
6d1b0f92 | 2374 | |
d0a4a61c | 2375 | break; |
d0a4a61c TB |
2376 | } |
2377 | ||
8c6a85e3 TB |
2378 | if (gfc_match_char (')') == MATCH_NO) |
2379 | goto syntax; | |
6de9cd9a | 2380 | |
8c6a85e3 TB |
2381 | *phead = head; |
2382 | *mask = msk; | |
6de9cd9a DN |
2383 | return MATCH_YES; |
2384 | ||
2385 | syntax: | |
8c6a85e3 | 2386 | gfc_syntax_error (ST_FORALL); |
6de9cd9a DN |
2387 | |
2388 | cleanup: | |
8c6a85e3 TB |
2389 | gfc_free_expr (msk); |
2390 | gfc_free_forall_iterator (head); | |
6de9cd9a | 2391 | |
6de9cd9a DN |
2392 | return MATCH_ERROR; |
2393 | } | |
2394 | ||
8b704316 | 2395 | /* Match the rest of a simple FORALL statement that follows an |
8c6a85e3 | 2396 | IF statement. */ |
66e4ab31 | 2397 | |
8c6a85e3 TB |
2398 | static match |
2399 | match_simple_forall (void) | |
6de9cd9a | 2400 | { |
8c6a85e3 TB |
2401 | gfc_forall_iterator *head; |
2402 | gfc_expr *mask; | |
2403 | gfc_code *c; | |
6de9cd9a DN |
2404 | match m; |
2405 | ||
8c6a85e3 TB |
2406 | mask = NULL; |
2407 | head = NULL; | |
2408 | c = NULL; | |
6de9cd9a | 2409 | |
8c6a85e3 | 2410 | m = match_forall_header (&head, &mask); |
6de9cd9a | 2411 | |
8c6a85e3 TB |
2412 | if (m == MATCH_NO) |
2413 | goto syntax; | |
2414 | if (m != MATCH_YES) | |
2415 | goto cleanup; | |
6de9cd9a | 2416 | |
8c6a85e3 | 2417 | m = gfc_match_assignment (); |
6de9cd9a | 2418 | |
8c6a85e3 TB |
2419 | if (m == MATCH_ERROR) |
2420 | goto cleanup; | |
2421 | if (m == MATCH_NO) | |
2422 | { | |
2423 | m = gfc_match_pointer_assignment (); | |
2424 | if (m == MATCH_ERROR) | |
2425 | goto cleanup; | |
2426 | if (m == MATCH_NO) | |
2427 | goto syntax; | |
2428 | } | |
6de9cd9a | 2429 | |
11e5274a | 2430 | c = XCNEW (gfc_code); |
8c6a85e3 TB |
2431 | *c = new_st; |
2432 | c->loc = gfc_current_locus; | |
d0a4a61c | 2433 | |
8c6a85e3 TB |
2434 | if (gfc_match_eos () != MATCH_YES) |
2435 | goto syntax; | |
d0a4a61c | 2436 | |
8c6a85e3 TB |
2437 | gfc_clear_new_st (); |
2438 | new_st.op = EXEC_FORALL; | |
2439 | new_st.expr1 = mask; | |
2440 | new_st.ext.forall_iterator = head; | |
11e5274a | 2441 | new_st.block = gfc_get_code (EXEC_FORALL); |
8c6a85e3 | 2442 | new_st.block->next = c; |
d0a4a61c | 2443 | |
8c6a85e3 | 2444 | return MATCH_YES; |
5493aa17 | 2445 | |
8c6a85e3 TB |
2446 | syntax: |
2447 | gfc_syntax_error (ST_FORALL); | |
5493aa17 | 2448 | |
8c6a85e3 TB |
2449 | cleanup: |
2450 | gfc_free_forall_iterator (head); | |
2451 | gfc_free_expr (mask); | |
5493aa17 | 2452 | |
8c6a85e3 TB |
2453 | return MATCH_ERROR; |
2454 | } | |
5493aa17 | 2455 | |
5493aa17 | 2456 | |
8c6a85e3 | 2457 | /* Match a FORALL statement. */ |
5493aa17 | 2458 | |
8c6a85e3 TB |
2459 | match |
2460 | gfc_match_forall (gfc_statement *st) | |
2461 | { | |
2462 | gfc_forall_iterator *head; | |
2463 | gfc_expr *mask; | |
2464 | gfc_code *c; | |
2465 | match m0, m; | |
5493aa17 | 2466 | |
8c6a85e3 TB |
2467 | head = NULL; |
2468 | mask = NULL; | |
2469 | c = NULL; | |
5493aa17 | 2470 | |
8c6a85e3 TB |
2471 | m0 = gfc_match_label (); |
2472 | if (m0 == MATCH_ERROR) | |
2473 | return MATCH_ERROR; | |
2474 | ||
2475 | m = gfc_match (" forall"); | |
2476 | if (m != MATCH_YES) | |
2477 | return m; | |
2478 | ||
2479 | m = match_forall_header (&head, &mask); | |
5493aa17 | 2480 | if (m == MATCH_ERROR) |
8c6a85e3 | 2481 | goto cleanup; |
5493aa17 | 2482 | if (m == MATCH_NO) |
8c6a85e3 TB |
2483 | goto syntax; |
2484 | ||
2485 | if (gfc_match_eos () == MATCH_YES) | |
5493aa17 | 2486 | { |
8c6a85e3 TB |
2487 | *st = ST_FORALL_BLOCK; |
2488 | new_st.op = EXEC_FORALL; | |
2489 | new_st.expr1 = mask; | |
2490 | new_st.ext.forall_iterator = head; | |
2491 | return MATCH_YES; | |
5493aa17 TB |
2492 | } |
2493 | ||
8c6a85e3 TB |
2494 | m = gfc_match_assignment (); |
2495 | if (m == MATCH_ERROR) | |
2496 | goto cleanup; | |
2497 | if (m == MATCH_NO) | |
5493aa17 | 2498 | { |
8c6a85e3 | 2499 | m = gfc_match_pointer_assignment (); |
5493aa17 | 2500 | if (m == MATCH_ERROR) |
8c6a85e3 TB |
2501 | goto cleanup; |
2502 | if (m == MATCH_NO) | |
5493aa17 | 2503 | goto syntax; |
8c6a85e3 | 2504 | } |
5493aa17 | 2505 | |
11e5274a | 2506 | c = XCNEW (gfc_code); |
8c6a85e3 TB |
2507 | *c = new_st; |
2508 | c->loc = gfc_current_locus; | |
5493aa17 | 2509 | |
8c6a85e3 TB |
2510 | gfc_clear_new_st (); |
2511 | new_st.op = EXEC_FORALL; | |
2512 | new_st.expr1 = mask; | |
2513 | new_st.ext.forall_iterator = head; | |
11e5274a | 2514 | new_st.block = gfc_get_code (EXEC_FORALL); |
8c6a85e3 | 2515 | new_st.block->next = c; |
5493aa17 | 2516 | |
8c6a85e3 TB |
2517 | *st = ST_FORALL; |
2518 | return MATCH_YES; | |
5493aa17 | 2519 | |
8c6a85e3 TB |
2520 | syntax: |
2521 | gfc_syntax_error (ST_FORALL); | |
5493aa17 | 2522 | |
8c6a85e3 TB |
2523 | cleanup: |
2524 | gfc_free_forall_iterator (head); | |
2525 | gfc_free_expr (mask); | |
2526 | gfc_free_statements (c); | |
2527 | return MATCH_NO; | |
2528 | } | |
5493aa17 | 2529 | |
5493aa17 | 2530 | |
8c6a85e3 | 2531 | /* Match a DO statement. */ |
5493aa17 | 2532 | |
8c6a85e3 TB |
2533 | match |
2534 | gfc_match_do (void) | |
2535 | { | |
2536 | gfc_iterator iter, *ip; | |
2537 | locus old_loc; | |
2538 | gfc_st_label *label; | |
2539 | match m; | |
5493aa17 | 2540 | |
8c6a85e3 TB |
2541 | old_loc = gfc_current_locus; |
2542 | ||
170a8bd6 | 2543 | memset (&iter, '\0', sizeof (gfc_iterator)); |
8c6a85e3 | 2544 | label = NULL; |
5493aa17 | 2545 | |
8c6a85e3 | 2546 | m = gfc_match_label (); |
5493aa17 | 2547 | if (m == MATCH_ERROR) |
8c6a85e3 | 2548 | return m; |
5493aa17 | 2549 | |
8c6a85e3 TB |
2550 | if (gfc_match (" do") != MATCH_YES) |
2551 | return MATCH_NO; | |
5493aa17 | 2552 | |
8c6a85e3 TB |
2553 | m = gfc_match_st_label (&label); |
2554 | if (m == MATCH_ERROR) | |
2555 | goto cleanup; | |
2556 | ||
2557 | /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */ | |
2558 | ||
2559 | if (gfc_match_eos () == MATCH_YES) | |
5493aa17 | 2560 | { |
8c6a85e3 TB |
2561 | iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true); |
2562 | new_st.op = EXEC_DO_WHILE; | |
2563 | goto done; | |
5493aa17 TB |
2564 | } |
2565 | ||
8c6a85e3 TB |
2566 | /* Match an optional comma, if no comma is found, a space is obligatory. */ |
2567 | if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES) | |
2568 | return MATCH_NO; | |
5493aa17 | 2569 | |
8c6a85e3 | 2570 | /* Check for balanced parens. */ |
8b704316 | 2571 | |
8c6a85e3 TB |
2572 | if (gfc_match_parens () == MATCH_ERROR) |
2573 | return MATCH_ERROR; | |
5493aa17 | 2574 | |
8c6a85e3 TB |
2575 | if (gfc_match (" concurrent") == MATCH_YES) |
2576 | { | |
2577 | gfc_forall_iterator *head; | |
2578 | gfc_expr *mask; | |
5493aa17 | 2579 | |
524af0d6 | 2580 | if (!gfc_notify_std (GFC_STD_F2008, "DO CONCURRENT construct at %C")) |
8c6a85e3 | 2581 | return MATCH_ERROR; |
5493aa17 | 2582 | |
d0a4a61c | 2583 | |
8c6a85e3 TB |
2584 | mask = NULL; |
2585 | head = NULL; | |
2586 | m = match_forall_header (&head, &mask); | |
d0a4a61c | 2587 | |
8c6a85e3 TB |
2588 | if (m == MATCH_NO) |
2589 | return m; | |
2590 | if (m == MATCH_ERROR) | |
2591 | goto concurr_cleanup; | |
d0a4a61c | 2592 | |
8c6a85e3 TB |
2593 | if (gfc_match_eos () != MATCH_YES) |
2594 | goto concurr_cleanup; | |
d0a4a61c | 2595 | |
8c6a85e3 | 2596 | if (label != NULL |
524af0d6 | 2597 | && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET)) |
8c6a85e3 | 2598 | goto concurr_cleanup; |
f1f39033 | 2599 | |
8c6a85e3 TB |
2600 | new_st.label1 = label; |
2601 | new_st.op = EXEC_DO_CONCURRENT; | |
2602 | new_st.expr1 = mask; | |
2603 | new_st.ext.forall_iterator = head; | |
d0a4a61c | 2604 | |
8c6a85e3 | 2605 | return MATCH_YES; |
f4d1d50a | 2606 | |
8c6a85e3 TB |
2607 | concurr_cleanup: |
2608 | gfc_syntax_error (ST_DO); | |
2609 | gfc_free_expr (mask); | |
2610 | gfc_free_forall_iterator (head); | |
d0a4a61c TB |
2611 | return MATCH_ERROR; |
2612 | } | |
5493aa17 | 2613 | |
8c6a85e3 TB |
2614 | /* See if we have a DO WHILE. */ |
2615 | if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES) | |
d0a4a61c | 2616 | { |
8c6a85e3 | 2617 | new_st.op = EXEC_DO_WHILE; |
d0a4a61c TB |
2618 | goto done; |
2619 | } | |
2620 | ||
8c6a85e3 TB |
2621 | /* The abortive DO WHILE may have done something to the symbol |
2622 | table, so we start over. */ | |
2623 | gfc_undo_symbols (); | |
2624 | gfc_current_locus = old_loc; | |
5493aa17 | 2625 | |
8c6a85e3 TB |
2626 | gfc_match_label (); /* This won't error. */ |
2627 | gfc_match (" do "); /* This will work. */ | |
d0a4a61c | 2628 | |
8c6a85e3 TB |
2629 | gfc_match_st_label (&label); /* Can't error out. */ |
2630 | gfc_match_char (','); /* Optional comma. */ | |
d0a4a61c | 2631 | |
8c6a85e3 TB |
2632 | m = gfc_match_iterator (&iter, 0); |
2633 | if (m == MATCH_NO) | |
2634 | return MATCH_NO; | |
2635 | if (m == MATCH_ERROR) | |
2636 | goto cleanup; | |
d0a4a61c | 2637 | |
8c6a85e3 TB |
2638 | iter.var->symtree->n.sym->attr.implied_index = 0; |
2639 | gfc_check_do_variable (iter.var->symtree); | |
d0a4a61c | 2640 | |
8c6a85e3 TB |
2641 | if (gfc_match_eos () != MATCH_YES) |
2642 | { | |
2643 | gfc_syntax_error (ST_DO); | |
2644 | goto cleanup; | |
d0a4a61c TB |
2645 | } |
2646 | ||
8c6a85e3 | 2647 | new_st.op = EXEC_DO; |
d0a4a61c TB |
2648 | |
2649 | done: | |
8c6a85e3 | 2650 | if (label != NULL |
524af0d6 | 2651 | && !gfc_reference_st_label (label, ST_LABEL_DO_TARGET)) |
8c6a85e3 TB |
2652 | goto cleanup; |
2653 | ||
2654 | new_st.label1 = label; | |
2655 | ||
2656 | if (new_st.op == EXEC_DO_WHILE) | |
2657 | new_st.expr1 = iter.end; | |
2658 | else | |
d0a4a61c | 2659 | { |
8c6a85e3 TB |
2660 | new_st.ext.iterator = ip = gfc_get_iterator (); |
2661 | *ip = iter; | |
d0a4a61c TB |
2662 | } |
2663 | ||
d0a4a61c TB |
2664 | return MATCH_YES; |
2665 | ||
d0a4a61c | 2666 | cleanup: |
8c6a85e3 | 2667 | gfc_free_iterator (&iter, 0); |
d0a4a61c TB |
2668 | |
2669 | return MATCH_ERROR; | |
2670 | } | |
2671 | ||
2672 | ||
8c6a85e3 | 2673 | /* Match an EXIT or CYCLE statement. */ |
d0a4a61c | 2674 | |
8c6a85e3 TB |
2675 | static match |
2676 | match_exit_cycle (gfc_statement st, gfc_exec_op op) | |
d0a4a61c | 2677 | { |
8c6a85e3 TB |
2678 | gfc_state_data *p, *o; |
2679 | gfc_symbol *sym; | |
2680 | match m; | |
2681 | int cnt; | |
d0a4a61c | 2682 | |
8c6a85e3 TB |
2683 | if (gfc_match_eos () == MATCH_YES) |
2684 | sym = NULL; | |
2685 | else | |
2686 | { | |
2687 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
2688 | gfc_symtree* stree; | |
d0a4a61c | 2689 | |
8c6a85e3 TB |
2690 | m = gfc_match ("% %n%t", name); |
2691 | if (m == MATCH_ERROR) | |
2692 | return MATCH_ERROR; | |
2693 | if (m == MATCH_NO) | |
2694 | { | |
2695 | gfc_syntax_error (st); | |
2696 | return MATCH_ERROR; | |
2697 | } | |
d0a4a61c | 2698 | |
8c6a85e3 TB |
2699 | /* Find the corresponding symbol. If there's a BLOCK statement |
2700 | between here and the label, it is not in gfc_current_ns but a parent | |
2701 | namespace! */ | |
2702 | stree = gfc_find_symtree_in_proc (name, gfc_current_ns); | |
2703 | if (!stree) | |
2704 | { | |
a4d9b221 | 2705 | gfc_error ("Name %qs in %s statement at %C is unknown", |
8c6a85e3 TB |
2706 | name, gfc_ascii_statement (st)); |
2707 | return MATCH_ERROR; | |
2708 | } | |
d0a4a61c | 2709 | |
8c6a85e3 TB |
2710 | sym = stree->n.sym; |
2711 | if (sym->attr.flavor != FL_LABEL) | |
2712 | { | |
a4d9b221 | 2713 | gfc_error ("Name %qs in %s statement at %C is not a construct name", |
8c6a85e3 TB |
2714 | name, gfc_ascii_statement (st)); |
2715 | return MATCH_ERROR; | |
2716 | } | |
2717 | } | |
d0a4a61c | 2718 | |
8c6a85e3 TB |
2719 | /* Find the loop specified by the label (or lack of a label). */ |
2720 | for (o = NULL, p = gfc_state_stack; p; p = p->previous) | |
2721 | if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK) | |
2722 | o = p; | |
2723 | else if (p->state == COMP_CRITICAL) | |
2724 | { | |
2725 | gfc_error("%s statement at %C leaves CRITICAL construct", | |
2726 | gfc_ascii_statement (st)); | |
2727 | return MATCH_ERROR; | |
2728 | } | |
2729 | else if (p->state == COMP_DO_CONCURRENT | |
2730 | && (op == EXEC_EXIT || (sym && sym != p->sym))) | |
2731 | { | |
2732 | /* F2008, C821 & C845. */ | |
2733 | gfc_error("%s statement at %C leaves DO CONCURRENT construct", | |
2734 | gfc_ascii_statement (st)); | |
2735 | return MATCH_ERROR; | |
2736 | } | |
2737 | else if ((sym && sym == p->sym) | |
2738 | || (!sym && (p->state == COMP_DO | |
2739 | || p->state == COMP_DO_CONCURRENT))) | |
2740 | break; | |
6de9cd9a | 2741 | |
8c6a85e3 | 2742 | if (p == NULL) |
6de9cd9a | 2743 | { |
8c6a85e3 TB |
2744 | if (sym == NULL) |
2745 | gfc_error ("%s statement at %C is not within a construct", | |
2746 | gfc_ascii_statement (st)); | |
2747 | else | |
a4d9b221 | 2748 | gfc_error ("%s statement at %C is not within construct %qs", |
8c6a85e3 TB |
2749 | gfc_ascii_statement (st), sym->name); |
2750 | ||
6de9cd9a DN |
2751 | return MATCH_ERROR; |
2752 | } | |
2753 | ||
8c6a85e3 TB |
2754 | /* Special checks for EXIT from non-loop constructs. */ |
2755 | switch (p->state) | |
2756 | { | |
2757 | case COMP_DO: | |
2758 | case COMP_DO_CONCURRENT: | |
2759 | break; | |
2760 | ||
2761 | case COMP_CRITICAL: | |
2762 | /* This is already handled above. */ | |
2763 | gcc_unreachable (); | |
2764 | ||
2765 | case COMP_ASSOCIATE: | |
2766 | case COMP_BLOCK: | |
2767 | case COMP_IF: | |
2768 | case COMP_SELECT: | |
2769 | case COMP_SELECT_TYPE: | |
2770 | gcc_assert (sym); | |
2771 | if (op == EXEC_CYCLE) | |
2772 | { | |
2773 | gfc_error ("CYCLE statement at %C is not applicable to non-loop" | |
a4d9b221 | 2774 | " construct %qs", sym->name); |
8c6a85e3 TB |
2775 | return MATCH_ERROR; |
2776 | } | |
2777 | gcc_assert (op == EXEC_EXIT); | |
524af0d6 JB |
2778 | if (!gfc_notify_std (GFC_STD_F2008, "EXIT statement with no" |
2779 | " do-construct-name at %C")) | |
8c6a85e3 TB |
2780 | return MATCH_ERROR; |
2781 | break; | |
8b704316 | 2782 | |
8c6a85e3 | 2783 | default: |
a4d9b221 | 2784 | gfc_error ("%s statement at %C is not applicable to construct %qs", |
8c6a85e3 TB |
2785 | gfc_ascii_statement (st), sym->name); |
2786 | return MATCH_ERROR; | |
2787 | } | |
2788 | ||
2789 | if (o != NULL) | |
2790 | { | |
41dbbb37 | 2791 | gfc_error (is_oacc (p) |
324ff1a0 JJ |
2792 | ? G_("%s statement at %C leaving OpenACC structured block") |
2793 | : G_("%s statement at %C leaving OpenMP structured block"), | |
8c6a85e3 TB |
2794 | gfc_ascii_statement (st)); |
2795 | return MATCH_ERROR; | |
2796 | } | |
2797 | ||
2798 | for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++) | |
2799 | o = o->previous; | |
2800 | if (cnt > 0 | |
2801 | && o != NULL | |
2802 | && o->state == COMP_OMP_STRUCTURED_BLOCK | |
41dbbb37 TS |
2803 | && (o->head->op == EXEC_OACC_LOOP |
2804 | || o->head->op == EXEC_OACC_PARALLEL_LOOP)) | |
2805 | { | |
2806 | int collapse = 1; | |
2807 | gcc_assert (o->head->next != NULL | |
2808 | && (o->head->next->op == EXEC_DO | |
2809 | || o->head->next->op == EXEC_DO_WHILE) | |
2810 | && o->previous != NULL | |
2811 | && o->previous->tail->op == o->head->op); | |
2812 | if (o->previous->tail->ext.omp_clauses != NULL | |
2813 | && o->previous->tail->ext.omp_clauses->collapse > 1) | |
2814 | collapse = o->previous->tail->ext.omp_clauses->collapse; | |
2815 | if (st == ST_EXIT && cnt <= collapse) | |
2816 | { | |
2817 | gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop"); | |
2818 | return MATCH_ERROR; | |
2819 | } | |
2820 | if (st == ST_CYCLE && cnt < collapse) | |
2821 | { | |
2822 | gfc_error ("CYCLE statement at %C to non-innermost collapsed" | |
2823 | " !$ACC LOOP loop"); | |
2824 | return MATCH_ERROR; | |
2825 | } | |
2826 | } | |
2827 | if (cnt > 0 | |
2828 | && o != NULL | |
2829 | && (o->state == COMP_OMP_STRUCTURED_BLOCK) | |
8c6a85e3 | 2830 | && (o->head->op == EXEC_OMP_DO |
dd2fc525 JJ |
2831 | || o->head->op == EXEC_OMP_PARALLEL_DO |
2832 | || o->head->op == EXEC_OMP_SIMD | |
2833 | || o->head->op == EXEC_OMP_DO_SIMD | |
2834 | || o->head->op == EXEC_OMP_PARALLEL_DO_SIMD)) | |
8c6a85e3 | 2835 | { |
b4c3a85b | 2836 | int count = 1; |
8c6a85e3 TB |
2837 | gcc_assert (o->head->next != NULL |
2838 | && (o->head->next->op == EXEC_DO | |
2839 | || o->head->next->op == EXEC_DO_WHILE) | |
2840 | && o->previous != NULL | |
2841 | && o->previous->tail->op == o->head->op); | |
b4c3a85b JJ |
2842 | if (o->previous->tail->ext.omp_clauses != NULL) |
2843 | { | |
2844 | if (o->previous->tail->ext.omp_clauses->collapse > 1) | |
2845 | count = o->previous->tail->ext.omp_clauses->collapse; | |
2846 | if (o->previous->tail->ext.omp_clauses->orderedc) | |
2847 | count = o->previous->tail->ext.omp_clauses->orderedc; | |
2848 | } | |
2849 | if (st == ST_EXIT && cnt <= count) | |
8c6a85e3 TB |
2850 | { |
2851 | gfc_error ("EXIT statement at %C terminating !$OMP DO loop"); | |
2852 | return MATCH_ERROR; | |
2853 | } | |
b4c3a85b | 2854 | if (st == ST_CYCLE && cnt < count) |
8c6a85e3 TB |
2855 | { |
2856 | gfc_error ("CYCLE statement at %C to non-innermost collapsed" | |
2857 | " !$OMP DO loop"); | |
2858 | return MATCH_ERROR; | |
2859 | } | |
2860 | } | |
2861 | ||
2862 | /* Save the first statement in the construct - needed by the backend. */ | |
2863 | new_st.ext.which_construct = p->construct; | |
2864 | ||
2865 | new_st.op = op; | |
2866 | ||
6de9cd9a DN |
2867 | return MATCH_YES; |
2868 | } | |
2869 | ||
2870 | ||
8c6a85e3 | 2871 | /* Match the EXIT statement. */ |
6de9cd9a DN |
2872 | |
2873 | match | |
8c6a85e3 | 2874 | gfc_match_exit (void) |
6de9cd9a | 2875 | { |
8c6a85e3 TB |
2876 | return match_exit_cycle (ST_EXIT, EXEC_EXIT); |
2877 | } | |
6de9cd9a | 2878 | |
6de9cd9a | 2879 | |
8c6a85e3 | 2880 | /* Match the CYCLE statement. */ |
6de9cd9a | 2881 | |
8c6a85e3 TB |
2882 | match |
2883 | gfc_match_cycle (void) | |
2884 | { | |
2885 | return match_exit_cycle (ST_CYCLE, EXEC_CYCLE); | |
6de9cd9a DN |
2886 | } |
2887 | ||
2888 | ||
4acf2055 SK |
2889 | /* Match a stop-code after an (ERROR) STOP or PAUSE statement. The |
2890 | requirements for a stop-code differ in the standards. | |
2891 | ||
2892 | Fortran 95 has | |
2893 | ||
2894 | R840 stop-stmt is STOP [ stop-code ] | |
2895 | R841 stop-code is scalar-char-constant | |
2896 | or digit [ digit [ digit [ digit [ digit ] ] ] ] | |
2897 | ||
2898 | Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850. | |
2899 | Fortran 2008 has | |
2900 | ||
2901 | R855 stop-stmt is STOP [ stop-code ] | |
2902 | R856 allstop-stmt is ALL STOP [ stop-code ] | |
2903 | R857 stop-code is scalar-default-char-constant-expr | |
2904 | or scalar-int-constant-expr | |
2905 | ||
2906 | For free-form source code, all standards contain a statement of the form: | |
2907 | ||
2908 | A blank shall be used to separate names, constants, or labels from | |
2909 | adjacent keywords, names, constants, or labels. | |
2910 | ||
2911 | A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003, | |
2912 | ||
2913 | STOP123 | |
2914 | ||
2915 | is valid, but it is invalid Fortran 2008. */ | |
6de9cd9a | 2916 | |
8c6a85e3 TB |
2917 | static match |
2918 | gfc_match_stopcode (gfc_statement st) | |
6de9cd9a | 2919 | { |
4acf2055 | 2920 | gfc_expr *e = NULL; |
6de9cd9a | 2921 | match m; |
4acf2055 SK |
2922 | bool f95, f03; |
2923 | ||
2924 | /* Set f95 for -std=f95. */ | |
2925 | f95 = gfc_option.allow_std == (GFC_STD_F95_OBS | GFC_STD_F95 | GFC_STD_F77 | |
2926 | | GFC_STD_F2008_OBS); | |
6de9cd9a | 2927 | |
4acf2055 | 2928 | /* Set f03 for -std=f2003. */ |
5bab4c96 | 2929 | f03 = gfc_option.allow_std == (GFC_STD_F95_OBS | GFC_STD_F95 | GFC_STD_F77 |
4acf2055 SK |
2930 | | GFC_STD_F2008_OBS | GFC_STD_F2003); |
2931 | ||
2932 | /* Look for a blank between STOP and the stop-code for F2008 or later. */ | |
2933 | if (gfc_current_form != FORM_FIXED && !(f95 || f03)) | |
2934 | { | |
2935 | char c = gfc_peek_ascii_char (); | |
2936 | ||
2937 | /* Look for end-of-statement. There is no stop-code. */ | |
2938 | if (c == '\n' || c == '!' || c == ';') | |
2939 | goto done; | |
2940 | ||
2941 | if (c != ' ') | |
2942 | { | |
2943 | gfc_error ("Blank required in %s statement near %C", | |
2944 | gfc_ascii_statement (st)); | |
2945 | return MATCH_ERROR; | |
2946 | } | |
2947 | } | |
8c6a85e3 TB |
2948 | |
2949 | if (gfc_match_eos () != MATCH_YES) | |
6de9cd9a | 2950 | { |
4acf2055 SK |
2951 | int stopcode; |
2952 | locus old_locus; | |
2953 | ||
2954 | /* First look for the F95 or F2003 digit [...] construct. */ | |
2955 | old_locus = gfc_current_locus; | |
2956 | m = gfc_match_small_int (&stopcode); | |
2957 | if (m == MATCH_YES && (f95 || f03)) | |
2958 | { | |
2959 | if (stopcode < 0) | |
2960 | { | |
2961 | gfc_error ("STOP code at %C cannot be negative"); | |
2962 | return MATCH_ERROR; | |
2963 | } | |
2964 | ||
2965 | if (stopcode > 99999) | |
2966 | { | |
2967 | gfc_error ("STOP code at %C contains too many digits"); | |
2968 | return MATCH_ERROR; | |
2969 | } | |
2970 | } | |
2971 | ||
2972 | /* Reset the locus and now load gfc_expr. */ | |
2973 | gfc_current_locus = old_locus; | |
2974 | m = gfc_match_expr (&e); | |
8c6a85e3 TB |
2975 | if (m == MATCH_ERROR) |
2976 | goto cleanup; | |
2977 | if (m == MATCH_NO) | |
2978 | goto syntax; | |
6de9cd9a | 2979 | |
8c6a85e3 TB |
2980 | if (gfc_match_eos () != MATCH_YES) |
2981 | goto syntax; | |
6de9cd9a DN |
2982 | } |
2983 | ||
8c6a85e3 | 2984 | if (gfc_pure (NULL)) |
6de9cd9a | 2985 | { |
2e9cc48c TB |
2986 | if (st == ST_ERROR_STOP) |
2987 | { | |
8179b067 | 2988 | if (!gfc_notify_std (GFC_STD_F2018, "%s statement at %C in PURE " |
2e9cc48c TB |
2989 | "procedure", gfc_ascii_statement (st))) |
2990 | goto cleanup; | |
2991 | } | |
2992 | else | |
2993 | { | |
2994 | gfc_error ("%s statement not allowed in PURE procedure at %C", | |
2995 | gfc_ascii_statement (st)); | |
2996 | goto cleanup; | |
2997 | } | |
8c6a85e3 | 2998 | } |
6de9cd9a | 2999 | |
ccd7751b | 3000 | gfc_unset_implicit_pure (NULL); |
6de9cd9a | 3001 | |
524af0d6 | 3002 | if (st == ST_STOP && gfc_find_state (COMP_CRITICAL)) |
8c6a85e3 TB |
3003 | { |
3004 | gfc_error ("Image control statement STOP at %C in CRITICAL block"); | |
3005 | goto cleanup; | |
3006 | } | |
524af0d6 | 3007 | if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT)) |
8c6a85e3 TB |
3008 | { |
3009 | gfc_error ("Image control statement STOP at %C in DO CONCURRENT block"); | |
3010 | goto cleanup; | |
3011 | } | |
6de9cd9a | 3012 | |
8c6a85e3 TB |
3013 | if (e != NULL) |
3014 | { | |
4acf2055 SK |
3015 | gfc_simplify_expr (e, 0); |
3016 | ||
3017 | /* Test for F95 and F2003 style STOP stop-code. */ | |
3018 | if (e->expr_type != EXPR_CONSTANT && (f95 || f03)) | |
3019 | { | |
3020 | gfc_error ("STOP code at %L must be a scalar CHARACTER constant or " | |
3021 | "digit[digit[digit[digit[digit]]]]", &e->where); | |
3022 | goto cleanup; | |
3023 | } | |
3024 | ||
3025 | /* Use the machinery for an initialization expression to reduce the | |
3026 | stop-code to a constant. */ | |
3027 | gfc_init_expr_flag = true; | |
3028 | gfc_reduce_init_expr (e); | |
3029 | gfc_init_expr_flag = false; | |
3030 | ||
8c6a85e3 | 3031 | if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER)) |
6de9cd9a | 3032 | { |
8c6a85e3 TB |
3033 | gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type", |
3034 | &e->where); | |
3035 | goto cleanup; | |
6de9cd9a | 3036 | } |
6de9cd9a | 3037 | |
8c6a85e3 | 3038 | if (e->rank != 0) |
6de9cd9a | 3039 | { |
4acf2055 | 3040 | gfc_error ("STOP code at %L must be scalar", &e->where); |
8c6a85e3 | 3041 | goto cleanup; |
6de9cd9a | 3042 | } |
6de9cd9a | 3043 | |
8c6a85e3 TB |
3044 | if (e->ts.type == BT_CHARACTER |
3045 | && e->ts.kind != gfc_default_character_kind) | |
6de9cd9a | 3046 | { |
8c6a85e3 TB |
3047 | gfc_error ("STOP code at %L must be default character KIND=%d", |
3048 | &e->where, (int) gfc_default_character_kind); | |
3049 | goto cleanup; | |
6de9cd9a | 3050 | } |
6de9cd9a | 3051 | |
4acf2055 | 3052 | if (e->ts.type == BT_INTEGER && e->ts.kind != gfc_default_integer_kind) |
8c6a85e3 TB |
3053 | { |
3054 | gfc_error ("STOP code at %L must be default integer KIND=%d", | |
3055 | &e->where, (int) gfc_default_integer_kind); | |
3056 | goto cleanup; | |
3057 | } | |
6de9cd9a DN |
3058 | } |
3059 | ||
4acf2055 SK |
3060 | done: |
3061 | ||
8c6a85e3 | 3062 | switch (st) |
6de9cd9a | 3063 | { |
8c6a85e3 TB |
3064 | case ST_STOP: |
3065 | new_st.op = EXEC_STOP; | |
3066 | break; | |
3067 | case ST_ERROR_STOP: | |
3068 | new_st.op = EXEC_ERROR_STOP; | |
3069 | break; | |
3070 | case ST_PAUSE: | |
3071 | new_st.op = EXEC_PAUSE; | |
3072 | break; | |
3073 | default: | |
3074 | gcc_unreachable (); | |
6de9cd9a DN |
3075 | } |
3076 | ||
8c6a85e3 TB |
3077 | new_st.expr1 = e; |
3078 | new_st.ext.stop_code = -1; | |
6de9cd9a | 3079 | |
6de9cd9a DN |
3080 | return MATCH_YES; |
3081 | ||
3082 | syntax: | |
8c6a85e3 TB |
3083 | gfc_syntax_error (st); |
3084 | ||
6de9cd9a | 3085 | cleanup: |
8c6a85e3 TB |
3086 | |
3087 | gfc_free_expr (e); | |
6de9cd9a DN |
3088 | return MATCH_ERROR; |
3089 | } | |
3090 | ||
3091 | ||
8c6a85e3 | 3092 | /* Match the (deprecated) PAUSE statement. */ |
6de9cd9a | 3093 | |
8c6a85e3 TB |
3094 | match |
3095 | gfc_match_pause (void) | |
6de9cd9a | 3096 | { |
8c6a85e3 | 3097 | match m; |
6de9cd9a | 3098 | |
8c6a85e3 TB |
3099 | m = gfc_match_stopcode (ST_PAUSE); |
3100 | if (m == MATCH_YES) | |
6de9cd9a | 3101 | { |
524af0d6 | 3102 | if (!gfc_notify_std (GFC_STD_F95_DEL, "PAUSE statement at %C")) |
8c6a85e3 | 3103 | m = MATCH_ERROR; |
6de9cd9a | 3104 | } |
8c6a85e3 | 3105 | return m; |
6de9cd9a DN |
3106 | } |
3107 | ||
3108 | ||
8c6a85e3 | 3109 | /* Match the STOP statement. */ |
cf2b3c22 | 3110 | |
8c6a85e3 TB |
3111 | match |
3112 | gfc_match_stop (void) | |
cf2b3c22 | 3113 | { |
8c6a85e3 TB |
3114 | return gfc_match_stopcode (ST_STOP); |
3115 | } | |
cf2b3c22 | 3116 | |
1fccc6c3 | 3117 | |
8c6a85e3 | 3118 | /* Match the ERROR STOP statement. */ |
1fccc6c3 | 3119 | |
8c6a85e3 TB |
3120 | match |
3121 | gfc_match_error_stop (void) | |
3122 | { | |
524af0d6 | 3123 | if (!gfc_notify_std (GFC_STD_F2008, "ERROR STOP statement at %C")) |
8c6a85e3 | 3124 | return MATCH_ERROR; |
cf2b3c22 | 3125 | |
8c6a85e3 | 3126 | return gfc_match_stopcode (ST_ERROR_STOP); |
cf2b3c22 TB |
3127 | } |
3128 | ||
5df445a2 TB |
3129 | /* Match EVENT POST/WAIT statement. Syntax: |
3130 | EVENT POST ( event-variable [, sync-stat-list] ) | |
3131 | EVENT WAIT ( event-variable [, wait-spec-list] ) | |
3132 | with | |
3133 | wait-spec-list is sync-stat-list or until-spec | |
3134 | until-spec is UNTIL_COUNT = scalar-int-expr | |
3135 | sync-stat is STAT= or ERRMSG=. */ | |
3136 | ||
3137 | static match | |
3138 | event_statement (gfc_statement st) | |
3139 | { | |
3140 | match m; | |
3141 | gfc_expr *tmp, *eventvar, *until_count, *stat, *errmsg; | |
3142 | bool saw_until_count, saw_stat, saw_errmsg; | |
3143 | ||
3144 | tmp = eventvar = until_count = stat = errmsg = NULL; | |
3145 | saw_until_count = saw_stat = saw_errmsg = false; | |
3146 | ||
3147 | if (gfc_pure (NULL)) | |
3148 | { | |
3149 | gfc_error ("Image control statement EVENT %s at %C in PURE procedure", | |
3150 | st == ST_EVENT_POST ? "POST" : "WAIT"); | |
3151 | return MATCH_ERROR; | |
3152 | } | |
3153 | ||
3154 | gfc_unset_implicit_pure (NULL); | |
3155 | ||
3156 | if (flag_coarray == GFC_FCOARRAY_NONE) | |
3157 | { | |
3158 | gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); | |
3159 | return MATCH_ERROR; | |
3160 | } | |
3161 | ||
3162 | if (gfc_find_state (COMP_CRITICAL)) | |
3163 | { | |
3164 | gfc_error ("Image control statement EVENT %s at %C in CRITICAL block", | |
3165 | st == ST_EVENT_POST ? "POST" : "WAIT"); | |
3166 | return MATCH_ERROR; | |
3167 | } | |
3168 | ||
3169 | if (gfc_find_state (COMP_DO_CONCURRENT)) | |
3170 | { | |
3171 | gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT " | |
3172 | "block", st == ST_EVENT_POST ? "POST" : "WAIT"); | |
3173 | return MATCH_ERROR; | |
3174 | } | |
3175 | ||
3176 | if (gfc_match_char ('(') != MATCH_YES) | |
3177 | goto syntax; | |
3178 | ||
3179 | if (gfc_match ("%e", &eventvar) != MATCH_YES) | |
3180 | goto syntax; | |
3181 | m = gfc_match_char (','); | |
3182 | if (m == MATCH_ERROR) | |
3183 | goto syntax; | |
3184 | if (m == MATCH_NO) | |
3185 | { | |
3186 | m = gfc_match_char (')'); | |
3187 | if (m == MATCH_YES) | |
3188 | goto done; | |
3189 | goto syntax; | |
3190 | } | |
3191 | ||
3192 | for (;;) | |
3193 | { | |
3194 | m = gfc_match (" stat = %v", &tmp); | |
3195 | if (m == MATCH_ERROR) | |
3196 | goto syntax; | |
3197 | if (m == MATCH_YES) | |
3198 | { | |
3199 | if (saw_stat) | |
3200 | { | |
2f029c08 | 3201 | gfc_error ("Redundant STAT tag found at %L", &tmp->where); |
5df445a2 TB |
3202 | goto cleanup; |
3203 | } | |
3204 | stat = tmp; | |
3205 | saw_stat = true; | |
3206 | ||
3207 | m = gfc_match_char (','); | |
3208 | if (m == MATCH_YES) | |
3209 | continue; | |
3210 | ||
3211 | tmp = NULL; | |
3212 | break; | |
3213 | } | |
3214 | ||
3215 | m = gfc_match (" errmsg = %v", &tmp); | |
3216 | if (m == MATCH_ERROR) | |
3217 | goto syntax; | |
3218 | if (m == MATCH_YES) | |
3219 | { | |
3220 | if (saw_errmsg) | |
3221 | { | |
2f029c08 | 3222 | gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); |
5df445a2 TB |
3223 | goto cleanup; |
3224 | } | |
3225 | errmsg = tmp; | |
3226 | saw_errmsg = true; | |
3227 | ||
3228 | m = gfc_match_char (','); | |
3229 | if (m == MATCH_YES) | |
3230 | continue; | |
3231 | ||
3232 | tmp = NULL; | |
3233 | break; | |
3234 | } | |
3235 | ||
3236 | m = gfc_match (" until_count = %e", &tmp); | |
3237 | if (m == MATCH_ERROR || st == ST_EVENT_POST) | |
3238 | goto syntax; | |
3239 | if (m == MATCH_YES) | |
3240 | { | |
3241 | if (saw_until_count) | |
3242 | { | |
2f029c08 | 3243 | gfc_error ("Redundant UNTIL_COUNT tag found at %L", |
5df445a2 TB |
3244 | &tmp->where); |
3245 | goto cleanup; | |
3246 | } | |
3247 | until_count = tmp; | |
3248 | saw_until_count = true; | |
3249 | ||
3250 | m = gfc_match_char (','); | |
3251 | if (m == MATCH_YES) | |
3252 | continue; | |
3253 | ||
3254 | tmp = NULL; | |
3255 | break; | |
3256 | } | |
3257 | ||
3258 | break; | |
3259 | } | |
3260 | ||
3261 | if (m == MATCH_ERROR) | |
3262 | goto syntax; | |
3263 | ||
3264 | if (gfc_match (" )%t") != MATCH_YES) | |
3265 | goto syntax; | |
3266 | ||
3267 | done: | |
3268 | switch (st) | |
3269 | { | |
3270 | case ST_EVENT_POST: | |
3271 | new_st.op = EXEC_EVENT_POST; | |
3272 | break; | |
3273 | case ST_EVENT_WAIT: | |
3274 | new_st.op = EXEC_EVENT_WAIT; | |
3275 | break; | |
3276 | default: | |
3277 | gcc_unreachable (); | |
3278 | } | |
3279 | ||
3280 | new_st.expr1 = eventvar; | |
3281 | new_st.expr2 = stat; | |
3282 | new_st.expr3 = errmsg; | |
3283 | new_st.expr4 = until_count; | |
3284 | ||
3285 | return MATCH_YES; | |
3286 | ||
3287 | syntax: | |
3288 | gfc_syntax_error (st); | |
3289 | ||
3290 | cleanup: | |
3291 | if (until_count != tmp) | |
3292 | gfc_free_expr (until_count); | |
3293 | if (errmsg != tmp) | |
3294 | gfc_free_expr (errmsg); | |
3295 | if (stat != tmp) | |
3296 | gfc_free_expr (stat); | |
3297 | ||
3298 | gfc_free_expr (tmp); | |
3299 | gfc_free_expr (eventvar); | |
3300 | ||
3301 | return MATCH_ERROR; | |
3302 | ||
3303 | } | |
3304 | ||
3305 | ||
3306 | match | |
3307 | gfc_match_event_post (void) | |
3308 | { | |
3309 | if (!gfc_notify_std (GFC_STD_F2008_TS, "EVENT POST statement at %C")) | |
3310 | return MATCH_ERROR; | |
3311 | ||
3312 | return event_statement (ST_EVENT_POST); | |
3313 | } | |
3314 | ||
3315 | ||
3316 | match | |
3317 | gfc_match_event_wait (void) | |
3318 | { | |
3319 | if (!gfc_notify_std (GFC_STD_F2008_TS, "EVENT WAIT statement at %C")) | |
3320 | return MATCH_ERROR; | |
3321 | ||
3322 | return event_statement (ST_EVENT_WAIT); | |
3323 | } | |
3324 | ||
cf2b3c22 | 3325 | |
ef78bc3c AV |
3326 | /* Match a FAIL IMAGE statement. */ |
3327 | ||
3328 | match | |
3329 | gfc_match_fail_image (void) | |
3330 | { | |
3331 | if (!gfc_notify_std (GFC_STD_F2008_TS, "FAIL IMAGE statement at %C")) | |
3332 | return MATCH_ERROR; | |
3333 | ||
3334 | if (gfc_match_char ('(') == MATCH_YES) | |
3335 | goto syntax; | |
3336 | ||
3337 | new_st.op = EXEC_FAIL_IMAGE; | |
3338 | ||
3339 | return MATCH_YES; | |
3340 | ||
3341 | syntax: | |
3342 | gfc_syntax_error (ST_FAIL_IMAGE); | |
3343 | ||
3344 | return MATCH_ERROR; | |
3345 | } | |
3346 | ||
3347 | ||
8c6a85e3 TB |
3348 | /* Match LOCK/UNLOCK statement. Syntax: |
3349 | LOCK ( lock-variable [ , lock-stat-list ] ) | |
3350 | UNLOCK ( lock-variable [ , sync-stat-list ] ) | |
3351 | where lock-stat is ACQUIRED_LOCK or sync-stat | |
3352 | and sync-stat is STAT= or ERRMSG=. */ | |
8234e5e0 SK |
3353 | |
3354 | static match | |
8c6a85e3 | 3355 | lock_unlock_statement (gfc_statement st) |
8234e5e0 SK |
3356 | { |
3357 | match m; | |
8c6a85e3 TB |
3358 | gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg; |
3359 | bool saw_acq_lock, saw_stat, saw_errmsg; | |
8234e5e0 | 3360 | |
8c6a85e3 TB |
3361 | tmp = lockvar = acq_lock = stat = errmsg = NULL; |
3362 | saw_acq_lock = saw_stat = saw_errmsg = false; | |
8234e5e0 | 3363 | |
8c6a85e3 | 3364 | if (gfc_pure (NULL)) |
1107bd38 | 3365 | { |
8c6a85e3 TB |
3366 | gfc_error ("Image control statement %s at %C in PURE procedure", |
3367 | st == ST_LOCK ? "LOCK" : "UNLOCK"); | |
3368 | return MATCH_ERROR; | |
1107bd38 | 3369 | } |
1107bd38 | 3370 | |
ccd7751b | 3371 | gfc_unset_implicit_pure (NULL); |
8c6a85e3 | 3372 | |
f19626cf | 3373 | if (flag_coarray == GFC_FCOARRAY_NONE) |
8234e5e0 | 3374 | { |
ddc05d11 | 3375 | gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); |
8c6a85e3 | 3376 | return MATCH_ERROR; |
8234e5e0 SK |
3377 | } |
3378 | ||
524af0d6 | 3379 | if (gfc_find_state (COMP_CRITICAL)) |
8234e5e0 | 3380 | { |
8c6a85e3 TB |
3381 | gfc_error ("Image control statement %s at %C in CRITICAL block", |
3382 | st == ST_LOCK ? "LOCK" : "UNLOCK"); | |
3383 | return MATCH_ERROR; | |
8234e5e0 SK |
3384 | } |
3385 | ||
524af0d6 | 3386 | if (gfc_find_state (COMP_DO_CONCURRENT)) |
8234e5e0 | 3387 | { |
8c6a85e3 TB |
3388 | gfc_error ("Image control statement %s at %C in DO CONCURRENT block", |
3389 | st == ST_LOCK ? "LOCK" : "UNLOCK"); | |
3390 | return MATCH_ERROR; | |
8234e5e0 SK |
3391 | } |
3392 | ||
8c6a85e3 TB |
3393 | if (gfc_match_char ('(') != MATCH_YES) |
3394 | goto syntax; | |
3395 | ||
3396 | if (gfc_match ("%e", &lockvar) != MATCH_YES) | |
3397 | goto syntax; | |
3398 | m = gfc_match_char (','); | |
3399 | if (m == MATCH_ERROR) | |
3400 | goto syntax; | |
3401 | if (m == MATCH_NO) | |
8234e5e0 | 3402 | { |
8c6a85e3 TB |
3403 | m = gfc_match_char (')'); |
3404 | if (m == MATCH_YES) | |
3405 | goto done; | |
3406 | goto syntax; | |
8234e5e0 SK |
3407 | } |
3408 | ||
8c6a85e3 | 3409 | for (;;) |
8234e5e0 | 3410 | { |
8c6a85e3 TB |
3411 | m = gfc_match (" stat = %v", &tmp); |
3412 | if (m == MATCH_ERROR) | |
3413 | goto syntax; | |
3414 | if (m == MATCH_YES) | |
3415 | { | |
3416 | if (saw_stat) | |
3417 | { | |
2f029c08 | 3418 | gfc_error ("Redundant STAT tag found at %L", &tmp->where); |
8c6a85e3 TB |
3419 | goto cleanup; |
3420 | } | |
3421 | stat = tmp; | |
3422 | saw_stat = true; | |
1fccc6c3 | 3423 | |
8c6a85e3 TB |
3424 | m = gfc_match_char (','); |
3425 | if (m == MATCH_YES) | |
3426 | continue; | |
1fccc6c3 | 3427 | |
8c6a85e3 TB |
3428 | tmp = NULL; |
3429 | break; | |
3430 | } | |
1fccc6c3 | 3431 | |
8c6a85e3 TB |
3432 | m = gfc_match (" errmsg = %v", &tmp); |
3433 | if (m == MATCH_ERROR) | |
3434 | goto syntax; | |
3435 | if (m == MATCH_YES) | |
3436 | { | |
3437 | if (saw_errmsg) | |
3438 | { | |
2f029c08 | 3439 | gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); |
8c6a85e3 TB |
3440 | goto cleanup; |
3441 | } | |
3442 | errmsg = tmp; | |
3443 | saw_errmsg = true; | |
8234e5e0 | 3444 | |
8c6a85e3 TB |
3445 | m = gfc_match_char (','); |
3446 | if (m == MATCH_YES) | |
3447 | continue; | |
8234e5e0 | 3448 | |
8c6a85e3 TB |
3449 | tmp = NULL; |
3450 | break; | |
3451 | } | |
8234e5e0 | 3452 | |
8c6a85e3 TB |
3453 | m = gfc_match (" acquired_lock = %v", &tmp); |
3454 | if (m == MATCH_ERROR || st == ST_UNLOCK) | |
3455 | goto syntax; | |
3456 | if (m == MATCH_YES) | |
3457 | { | |
3458 | if (saw_acq_lock) | |
3459 | { | |
2f029c08 | 3460 | gfc_error ("Redundant ACQUIRED_LOCK tag found at %L", |
8c6a85e3 TB |
3461 | &tmp->where); |
3462 | goto cleanup; | |
3463 | } | |
3464 | acq_lock = tmp; | |
3465 | saw_acq_lock = true; | |
8234e5e0 | 3466 | |
8c6a85e3 TB |
3467 | m = gfc_match_char (','); |
3468 | if (m == MATCH_YES) | |
3469 | continue; | |
3470 | ||
3471 | tmp = NULL; | |
3472 | break; | |
3473 | } | |
3474 | ||
3475 | break; | |
3476 | } | |
3477 | ||
3478 | if (m == MATCH_ERROR) | |
3479 | goto syntax; | |
3480 | ||
3481 | if (gfc_match (" )%t") != MATCH_YES) | |
3482 | goto syntax; | |
3483 | ||
3484 | done: | |
3485 | switch (st) | |
8234e5e0 | 3486 | { |
8c6a85e3 TB |
3487 | case ST_LOCK: |
3488 | new_st.op = EXEC_LOCK; | |
3489 | break; | |
3490 | case ST_UNLOCK: | |
3491 | new_st.op = EXEC_UNLOCK; | |
3492 | break; | |
3493 | default: | |
3494 | gcc_unreachable (); | |
8234e5e0 SK |
3495 | } |
3496 | ||
8c6a85e3 TB |
3497 | new_st.expr1 = lockvar; |
3498 | new_st.expr2 = stat; | |
3499 | new_st.expr3 = errmsg; | |
3500 | new_st.expr4 = acq_lock; | |
8234e5e0 | 3501 | |
8c6a85e3 | 3502 | return MATCH_YES; |
8234e5e0 | 3503 | |
8c6a85e3 TB |
3504 | syntax: |
3505 | gfc_syntax_error (st); | |
3506 | ||
3507 | cleanup: | |
fd2805e1 TB |
3508 | if (acq_lock != tmp) |
3509 | gfc_free_expr (acq_lock); | |
3510 | if (errmsg != tmp) | |
3511 | gfc_free_expr (errmsg); | |
3512 | if (stat != tmp) | |
3513 | gfc_free_expr (stat); | |
3514 | ||
8c6a85e3 TB |
3515 | gfc_free_expr (tmp); |
3516 | gfc_free_expr (lockvar); | |
8c6a85e3 TB |
3517 | |
3518 | return MATCH_ERROR; | |
8234e5e0 SK |
3519 | } |
3520 | ||
3521 | ||
8c6a85e3 TB |
3522 | match |
3523 | gfc_match_lock (void) | |
3524 | { | |
524af0d6 | 3525 | if (!gfc_notify_std (GFC_STD_F2008, "LOCK statement at %C")) |
8c6a85e3 TB |
3526 | return MATCH_ERROR; |
3527 | ||
3528 | return lock_unlock_statement (ST_LOCK); | |
3529 | } | |
3530 | ||
6de9cd9a DN |
3531 | |
3532 | match | |
8c6a85e3 | 3533 | gfc_match_unlock (void) |
6de9cd9a | 3534 | { |
524af0d6 | 3535 | if (!gfc_notify_std (GFC_STD_F2008, "UNLOCK statement at %C")) |
8c6a85e3 | 3536 | return MATCH_ERROR; |
6de9cd9a | 3537 | |
8c6a85e3 TB |
3538 | return lock_unlock_statement (ST_UNLOCK); |
3539 | } | |
6de9cd9a | 3540 | |
6de9cd9a | 3541 | |
8c6a85e3 TB |
3542 | /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax: |
3543 | SYNC ALL [(sync-stat-list)] | |
3544 | SYNC MEMORY [(sync-stat-list)] | |
3545 | SYNC IMAGES (image-set [, sync-stat-list] ) | |
3546 | with sync-stat is int-expr or *. */ | |
1fccc6c3 | 3547 | |
8c6a85e3 TB |
3548 | static match |
3549 | sync_statement (gfc_statement st) | |
3550 | { | |
3551 | match m; | |
3552 | gfc_expr *tmp, *imageset, *stat, *errmsg; | |
3553 | bool saw_stat, saw_errmsg; | |
1fccc6c3 | 3554 | |
8c6a85e3 TB |
3555 | tmp = imageset = stat = errmsg = NULL; |
3556 | saw_stat = saw_errmsg = false; | |
3557 | ||
3558 | if (gfc_pure (NULL)) | |
3559 | { | |
3560 | gfc_error ("Image control statement SYNC at %C in PURE procedure"); | |
3561 | return MATCH_ERROR; | |
1fccc6c3 | 3562 | } |
8c6a85e3 | 3563 | |
ccd7751b | 3564 | gfc_unset_implicit_pure (NULL); |
8c6a85e3 | 3565 | |
524af0d6 | 3566 | if (!gfc_notify_std (GFC_STD_F2008, "SYNC statement at %C")) |
8c6a85e3 TB |
3567 | return MATCH_ERROR; |
3568 | ||
f19626cf | 3569 | if (flag_coarray == GFC_FCOARRAY_NONE) |
8234e5e0 | 3570 | { |
ddc05d11 TB |
3571 | gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to " |
3572 | "enable"); | |
8c6a85e3 TB |
3573 | return MATCH_ERROR; |
3574 | } | |
e69afb29 | 3575 | |
524af0d6 | 3576 | if (gfc_find_state (COMP_CRITICAL)) |
8c6a85e3 TB |
3577 | { |
3578 | gfc_error ("Image control statement SYNC at %C in CRITICAL block"); | |
3579 | return MATCH_ERROR; | |
8234e5e0 SK |
3580 | } |
3581 | ||
524af0d6 | 3582 | if (gfc_find_state (COMP_DO_CONCURRENT)) |
6de9cd9a | 3583 | { |
8c6a85e3 TB |
3584 | gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block"); |
3585 | return MATCH_ERROR; | |
3586 | } | |
6de9cd9a | 3587 | |
8c6a85e3 TB |
3588 | if (gfc_match_eos () == MATCH_YES) |
3589 | { | |
3590 | if (st == ST_SYNC_IMAGES) | |
6de9cd9a | 3591 | goto syntax; |
8c6a85e3 TB |
3592 | goto done; |
3593 | } | |
6de9cd9a | 3594 | |
8c6a85e3 TB |
3595 | if (gfc_match_char ('(') != MATCH_YES) |
3596 | goto syntax; | |
c9583ed2 | 3597 | |
8c6a85e3 TB |
3598 | if (st == ST_SYNC_IMAGES) |
3599 | { | |
3600 | /* Denote '*' as imageset == NULL. */ | |
3601 | m = gfc_match_char ('*'); | |
3602 | if (m == MATCH_ERROR) | |
3603 | goto syntax; | |
3604 | if (m == MATCH_NO) | |
6de9cd9a | 3605 | { |
8c6a85e3 TB |
3606 | if (gfc_match ("%e", &imageset) != MATCH_YES) |
3607 | goto syntax; | |
6de9cd9a | 3608 | } |
8c6a85e3 TB |
3609 | m = gfc_match_char (','); |
3610 | if (m == MATCH_ERROR) | |
3611 | goto syntax; | |
3612 | if (m == MATCH_NO) | |
e69afb29 | 3613 | { |
8c6a85e3 TB |
3614 | m = gfc_match_char (')'); |
3615 | if (m == MATCH_YES) | |
3616 | goto done; | |
3617 | goto syntax; | |
e69afb29 | 3618 | } |
8c6a85e3 | 3619 | } |
e69afb29 | 3620 | |
8c6a85e3 TB |
3621 | for (;;) |
3622 | { | |
3623 | m = gfc_match (" stat = %v", &tmp); | |
3624 | if (m == MATCH_ERROR) | |
3625 | goto syntax; | |
3626 | if (m == MATCH_YES) | |
8234e5e0 | 3627 | { |
8c6a85e3 | 3628 | if (saw_stat) |
8234e5e0 | 3629 | { |
2f029c08 | 3630 | gfc_error ("Redundant STAT tag found at %L", &tmp->where); |
8234e5e0 SK |
3631 | goto cleanup; |
3632 | } | |
8c6a85e3 TB |
3633 | stat = tmp; |
3634 | saw_stat = true; | |
8234e5e0 | 3635 | |
8c6a85e3 TB |
3636 | if (gfc_match_char (',') == MATCH_YES) |
3637 | continue; | |
3638 | ||
3639 | tmp = NULL; | |
3640 | break; | |
3641 | } | |
3642 | ||
3643 | m = gfc_match (" errmsg = %v", &tmp); | |
3644 | if (m == MATCH_ERROR) | |
3645 | goto syntax; | |
3646 | if (m == MATCH_YES) | |
3647 | { | |
3648 | if (saw_errmsg) | |
8234e5e0 | 3649 | { |
2f029c08 | 3650 | gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); |
8234e5e0 SK |
3651 | goto cleanup; |
3652 | } | |
8c6a85e3 TB |
3653 | errmsg = tmp; |
3654 | saw_errmsg = true; | |
8234e5e0 | 3655 | |
8c6a85e3 TB |
3656 | if (gfc_match_char (',') == MATCH_YES) |
3657 | continue; | |
3e978d30 | 3658 | |
8c6a85e3 TB |
3659 | tmp = NULL; |
3660 | break; | |
d59b1dcb DF |
3661 | } |
3662 | ||
6de9cd9a | 3663 | break; |
8c6a85e3 | 3664 | } |
6de9cd9a | 3665 | |
8c6a85e3 TB |
3666 | if (gfc_match (" )%t") != MATCH_YES) |
3667 | goto syntax; | |
3759634f | 3668 | |
8c6a85e3 TB |
3669 | done: |
3670 | switch (st) | |
3671 | { | |
3672 | case ST_SYNC_ALL: | |
3673 | new_st.op = EXEC_SYNC_ALL; | |
3674 | break; | |
3675 | case ST_SYNC_IMAGES: | |
3676 | new_st.op = EXEC_SYNC_IMAGES; | |
3677 | break; | |
3678 | case ST_SYNC_MEMORY: | |
3679 | new_st.op = EXEC_SYNC_MEMORY; | |
3680 | break; | |
3681 | default: | |
3682 | gcc_unreachable (); | |
3683 | } | |
3759634f | 3684 | |
8c6a85e3 TB |
3685 | new_st.expr1 = imageset; |
3686 | new_st.expr2 = stat; | |
3687 | new_st.expr3 = errmsg; | |
3759634f | 3688 | |
8c6a85e3 | 3689 | return MATCH_YES; |
3759634f | 3690 | |
8c6a85e3 TB |
3691 | syntax: |
3692 | gfc_syntax_error (st); | |
8234e5e0 | 3693 | |
8c6a85e3 | 3694 | cleanup: |
fd2805e1 TB |
3695 | if (stat != tmp) |
3696 | gfc_free_expr (stat); | |
3697 | if (errmsg != tmp) | |
3698 | gfc_free_expr (errmsg); | |
3699 | ||
8c6a85e3 TB |
3700 | gfc_free_expr (tmp); |
3701 | gfc_free_expr (imageset); | |
8234e5e0 | 3702 | |
8c6a85e3 TB |
3703 | return MATCH_ERROR; |
3704 | } | |
8234e5e0 | 3705 | |
8234e5e0 | 3706 | |
8c6a85e3 | 3707 | /* Match SYNC ALL statement. */ |
8234e5e0 | 3708 | |
8c6a85e3 TB |
3709 | match |
3710 | gfc_match_sync_all (void) | |
3711 | { | |
3712 | return sync_statement (ST_SYNC_ALL); | |
3713 | } | |
8234e5e0 | 3714 | |
94bff632 | 3715 | |
8c6a85e3 | 3716 | /* Match SYNC IMAGES statement. */ |
94bff632 | 3717 | |
8c6a85e3 TB |
3718 | match |
3719 | gfc_match_sync_images (void) | |
3720 | { | |
3721 | return sync_statement (ST_SYNC_IMAGES); | |
3722 | } | |
94bff632 | 3723 | |
94bff632 | 3724 | |
8c6a85e3 | 3725 | /* Match SYNC MEMORY statement. */ |
3759634f | 3726 | |
8c6a85e3 TB |
3727 | match |
3728 | gfc_match_sync_memory (void) | |
3729 | { | |
3730 | return sync_statement (ST_SYNC_MEMORY); | |
3731 | } | |
6de9cd9a | 3732 | |
6de9cd9a | 3733 | |
8c6a85e3 | 3734 | /* Match a CONTINUE statement. */ |
e69afb29 | 3735 | |
8c6a85e3 TB |
3736 | match |
3737 | gfc_match_continue (void) | |
3738 | { | |
3739 | if (gfc_match_eos () != MATCH_YES) | |
e69afb29 | 3740 | { |
8c6a85e3 TB |
3741 | gfc_syntax_error (ST_CONTINUE); |
3742 | return MATCH_ERROR; | |
e69afb29 | 3743 | } |
6de9cd9a | 3744 | |
8c6a85e3 | 3745 | new_st.op = EXEC_CONTINUE; |
6de9cd9a | 3746 | return MATCH_YES; |
6de9cd9a DN |
3747 | } |
3748 | ||
3749 | ||
8c6a85e3 | 3750 | /* Match the (deprecated) ASSIGN statement. */ |
6de9cd9a DN |
3751 | |
3752 | match | |
8c6a85e3 | 3753 | gfc_match_assign (void) |
6de9cd9a | 3754 | { |
8c6a85e3 TB |
3755 | gfc_expr *expr; |
3756 | gfc_st_label *label; | |
6de9cd9a | 3757 | |
8c6a85e3 | 3758 | if (gfc_match (" %l", &label) == MATCH_YES) |
6de9cd9a | 3759 | { |
524af0d6 | 3760 | if (!gfc_reference_st_label (label, ST_LABEL_UNKNOWN)) |
8c6a85e3 TB |
3761 | return MATCH_ERROR; |
3762 | if (gfc_match (" to %v%t", &expr) == MATCH_YES) | |
5aacb11e | 3763 | { |
524af0d6 | 3764 | if (!gfc_notify_std (GFC_STD_F95_DEL, "ASSIGN statement at %C")) |
8c6a85e3 | 3765 | return MATCH_ERROR; |
5aacb11e | 3766 | |
8c6a85e3 | 3767 | expr->symtree->n.sym->attr.assign = 1; |
6de9cd9a | 3768 | |
8c6a85e3 TB |
3769 | new_st.op = EXEC_LABEL_ASSIGN; |
3770 | new_st.label1 = label; | |
3771 | new_st.expr1 = expr; | |
3772 | return MATCH_YES; | |
6de9cd9a | 3773 | } |
6de9cd9a | 3774 | } |
8c6a85e3 | 3775 | return MATCH_NO; |
6de9cd9a DN |
3776 | } |
3777 | ||
3778 | ||
8c6a85e3 TB |
3779 | /* Match the GO TO statement. As a computed GOTO statement is |
3780 | matched, it is transformed into an equivalent SELECT block. No | |
3781 | tree is necessary, and the resulting jumps-to-jumps are | |
3782 | specifically optimized away by the back end. */ | |
6de9cd9a DN |
3783 | |
3784 | match | |
8c6a85e3 | 3785 | gfc_match_goto (void) |
6de9cd9a | 3786 | { |
8c6a85e3 TB |
3787 | gfc_code *head, *tail; |
3788 | gfc_expr *expr; | |
3789 | gfc_case *cp; | |
3790 | gfc_st_label *label; | |
3791 | int i; | |
6de9cd9a | 3792 | match m; |
6de9cd9a | 3793 | |
8c6a85e3 | 3794 | if (gfc_match (" %l%t", &label) == MATCH_YES) |
6de9cd9a | 3795 | { |
524af0d6 | 3796 | if (!gfc_reference_st_label (label, ST_LABEL_TARGET)) |
8c6a85e3 | 3797 | return MATCH_ERROR; |
6de9cd9a | 3798 | |
8c6a85e3 TB |
3799 | new_st.op = EXEC_GOTO; |
3800 | new_st.label1 = label; | |
3801 | return MATCH_YES; | |
3802 | } | |
6de9cd9a | 3803 | |
8b704316 | 3804 | /* The assigned GO TO statement. */ |
c9583ed2 | 3805 | |
8c6a85e3 TB |
3806 | if (gfc_match_variable (&expr, 0) == MATCH_YES) |
3807 | { | |
524af0d6 | 3808 | if (!gfc_notify_std (GFC_STD_F95_DEL, "Assigned GOTO statement at %C")) |
8c6a85e3 | 3809 | return MATCH_ERROR; |
cf2b3c22 | 3810 | |
8c6a85e3 TB |
3811 | new_st.op = EXEC_GOTO; |
3812 | new_st.expr1 = expr; | |
3759634f | 3813 | |
8c6a85e3 TB |
3814 | if (gfc_match_eos () == MATCH_YES) |
3815 | return MATCH_YES; | |
f1f39033 | 3816 | |
8c6a85e3 TB |
3817 | /* Match label list. */ |
3818 | gfc_match_char (','); | |
3819 | if (gfc_match_char ('(') != MATCH_YES) | |
3759634f | 3820 | { |
8c6a85e3 TB |
3821 | gfc_syntax_error (ST_GOTO); |
3822 | return MATCH_ERROR; | |
6de9cd9a | 3823 | } |
8c6a85e3 | 3824 | head = tail = NULL; |
6de9cd9a | 3825 | |
8c6a85e3 TB |
3826 | do |
3827 | { | |
3828 | m = gfc_match_st_label (&label); | |
3829 | if (m != MATCH_YES) | |
3830 | goto syntax; | |
6de9cd9a | 3831 | |
524af0d6 | 3832 | if (!gfc_reference_st_label (label, ST_LABEL_TARGET)) |
8c6a85e3 | 3833 | goto cleanup; |
3759634f | 3834 | |
8c6a85e3 | 3835 | if (head == NULL) |
11e5274a | 3836 | head = tail = gfc_get_code (EXEC_GOTO); |
8c6a85e3 | 3837 | else |
3759634f | 3838 | { |
11e5274a | 3839 | tail->block = gfc_get_code (EXEC_GOTO); |
8c6a85e3 | 3840 | tail = tail->block; |
3759634f SK |
3841 | } |
3842 | ||
8c6a85e3 | 3843 | tail->label1 = label; |
8c6a85e3 TB |
3844 | } |
3845 | while (gfc_match_char (',') == MATCH_YES); | |
3759634f | 3846 | |
8c6a85e3 TB |
3847 | if (gfc_match (")%t") != MATCH_YES) |
3848 | goto syntax; | |
6de9cd9a | 3849 | |
8c6a85e3 TB |
3850 | if (head == NULL) |
3851 | { | |
3852 | gfc_error ("Statement label list in GOTO at %C cannot be empty"); | |
3853 | goto syntax; | |
3759634f | 3854 | } |
8c6a85e3 | 3855 | new_st.block = head; |
3759634f | 3856 | |
8c6a85e3 TB |
3857 | return MATCH_YES; |
3858 | } | |
3759634f | 3859 | |
8c6a85e3 TB |
3860 | /* Last chance is a computed GO TO statement. */ |
3861 | if (gfc_match_char ('(') != MATCH_YES) | |
3862 | { | |
3863 | gfc_syntax_error (ST_GOTO); | |
3864 | return MATCH_ERROR; | |
3865 | } | |
3759634f | 3866 | |
8c6a85e3 TB |
3867 | head = tail = NULL; |
3868 | i = 1; | |
3759634f | 3869 | |
8c6a85e3 TB |
3870 | do |
3871 | { | |
3872 | m = gfc_match_st_label (&label); | |
3873 | if (m != MATCH_YES) | |
3874 | goto syntax; | |
3875 | ||
524af0d6 | 3876 | if (!gfc_reference_st_label (label, ST_LABEL_TARGET)) |
8c6a85e3 TB |
3877 | goto cleanup; |
3878 | ||
3879 | if (head == NULL) | |
11e5274a | 3880 | head = tail = gfc_get_code (EXEC_SELECT); |
8c6a85e3 TB |
3881 | else |
3882 | { | |
11e5274a | 3883 | tail->block = gfc_get_code (EXEC_SELECT); |
8c6a85e3 | 3884 | tail = tail->block; |
3759634f SK |
3885 | } |
3886 | ||
8c6a85e3 TB |
3887 | cp = gfc_get_case (); |
3888 | cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind, | |
3889 | NULL, i++); | |
3759634f | 3890 | |
8c6a85e3 TB |
3891 | tail->ext.block.case_list = cp; |
3892 | ||
11e5274a | 3893 | tail->next = gfc_get_code (EXEC_GOTO); |
8c6a85e3 | 3894 | tail->next->label1 = label; |
3759634f | 3895 | } |
8c6a85e3 | 3896 | while (gfc_match_char (',') == MATCH_YES); |
6de9cd9a | 3897 | |
8c6a85e3 | 3898 | if (gfc_match_char (')') != MATCH_YES) |
6de9cd9a DN |
3899 | goto syntax; |
3900 | ||
8c6a85e3 TB |
3901 | if (head == NULL) |
3902 | { | |
3903 | gfc_error ("Statement label list in GOTO at %C cannot be empty"); | |
3904 | goto syntax; | |
3905 | } | |
6de9cd9a | 3906 | |
8c6a85e3 TB |
3907 | /* Get the rest of the statement. */ |
3908 | gfc_match_char (','); | |
6de9cd9a | 3909 | |
8c6a85e3 TB |
3910 | if (gfc_match (" %e%t", &expr) != MATCH_YES) |
3911 | goto syntax; | |
6de9cd9a | 3912 | |
524af0d6 | 3913 | if (!gfc_notify_std (GFC_STD_F95_OBS, "Computed GOTO at %C")) |
e2ab8b09 JW |
3914 | return MATCH_ERROR; |
3915 | ||
8c6a85e3 TB |
3916 | /* At this point, a computed GOTO has been fully matched and an |
3917 | equivalent SELECT statement constructed. */ | |
7f42f27f | 3918 | |
8c6a85e3 TB |
3919 | new_st.op = EXEC_SELECT; |
3920 | new_st.expr1 = NULL; | |
6de9cd9a | 3921 | |
8c6a85e3 TB |
3922 | /* Hack: For a "real" SELECT, the expression is in expr. We put |
3923 | it in expr2 so we can distinguish then and produce the correct | |
3924 | diagnostics. */ | |
3925 | new_st.expr2 = expr; | |
3926 | new_st.block = head; | |
3927 | return MATCH_YES; | |
6de9cd9a | 3928 | |
8c6a85e3 TB |
3929 | syntax: |
3930 | gfc_syntax_error (ST_GOTO); | |
6de9cd9a | 3931 | cleanup: |
8c6a85e3 | 3932 | gfc_free_statements (head); |
6de9cd9a | 3933 | return MATCH_ERROR; |
6de9cd9a DN |
3934 | } |
3935 | ||
3936 | ||
8c6a85e3 | 3937 | /* Frees a list of gfc_alloc structures. */ |
8e1f752a | 3938 | |
8c6a85e3 TB |
3939 | void |
3940 | gfc_free_alloc_list (gfc_alloc *p) | |
8e1f752a | 3941 | { |
8c6a85e3 | 3942 | gfc_alloc *q; |
8e1f752a | 3943 | |
8c6a85e3 | 3944 | for (; p; p = q) |
8e1f752a | 3945 | { |
8c6a85e3 TB |
3946 | q = p->next; |
3947 | gfc_free_expr (p->expr); | |
3948 | free (p); | |
8e1f752a | 3949 | } |
8e1f752a DK |
3950 | } |
3951 | ||
3952 | ||
8c6a85e3 | 3953 | /* Match an ALLOCATE statement. */ |
6de9cd9a DN |
3954 | |
3955 | match | |
8c6a85e3 | 3956 | gfc_match_allocate (void) |
6de9cd9a | 3957 | { |
8c6a85e3 TB |
3958 | gfc_alloc *head, *tail; |
3959 | gfc_expr *stat, *errmsg, *tmp, *source, *mold; | |
3960 | gfc_typespec ts; | |
6de9cd9a | 3961 | gfc_symbol *sym; |
6de9cd9a | 3962 | match m; |
d36eb6bf | 3963 | locus old_locus, deferred_locus, assumed_locus; |
8c6a85e3 | 3964 | bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3; |
d36eb6bf | 3965 | bool saw_unlimited = false, saw_assumed = false; |
6de9cd9a | 3966 | |
8c6a85e3 TB |
3967 | head = tail = NULL; |
3968 | stat = errmsg = source = mold = tmp = NULL; | |
3969 | saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false; | |
6de9cd9a | 3970 | |
8c6a85e3 | 3971 | if (gfc_match_char ('(') != MATCH_YES) |
fdfcd5ec SK |
3972 | { |
3973 | gfc_syntax_error (ST_ALLOCATE); | |
3974 | return MATCH_ERROR; | |
3975 | } | |
6de9cd9a | 3976 | |
8c6a85e3 TB |
3977 | /* Match an optional type-spec. */ |
3978 | old_locus = gfc_current_locus; | |
894460a7 | 3979 | m = gfc_match_type_spec (&ts); |
8c6a85e3 TB |
3980 | if (m == MATCH_ERROR) |
3981 | goto cleanup; | |
3982 | else if (m == MATCH_NO) | |
3983 | { | |
3984 | char name[GFC_MAX_SYMBOL_LEN + 3]; | |
6de9cd9a | 3985 | |
8c6a85e3 TB |
3986 | if (gfc_match ("%n :: ", name) == MATCH_YES) |
3987 | { | |
3988 | gfc_error ("Error in type-spec at %L", &old_locus); | |
3989 | goto cleanup; | |
3990 | } | |
8e1f752a | 3991 | |
8c6a85e3 TB |
3992 | ts.type = BT_UNKNOWN; |
3993 | } | |
3994 | else | |
6291f3ba | 3995 | { |
d36eb6bf SK |
3996 | /* Needed for the F2008:C631 check below. */ |
3997 | assumed_locus = gfc_current_locus; | |
3998 | ||
8c6a85e3 | 3999 | if (gfc_match (" :: ") == MATCH_YES) |
eda0ed25 | 4000 | { |
5bab4c96 | 4001 | if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L", |
524af0d6 | 4002 | &old_locus)) |
8c6a85e3 | 4003 | goto cleanup; |
6de9cd9a | 4004 | |
8c6a85e3 TB |
4005 | if (ts.deferred) |
4006 | { | |
4007 | gfc_error ("Type-spec at %L cannot contain a deferred " | |
4008 | "type parameter", &old_locus); | |
4009 | goto cleanup; | |
4010 | } | |
239b48db TB |
4011 | |
4012 | if (ts.type == BT_CHARACTER) | |
d36eb6bf SK |
4013 | { |
4014 | if (!ts.u.cl->length) | |
4015 | saw_assumed = true; | |
4016 | else | |
4017 | ts.u.cl->length_from_typespec = true; | |
4018 | } | |
5bab4c96 | 4019 | |
d36eb6bf SK |
4020 | if (type_param_spec_list |
4021 | && gfc_spec_list_type (type_param_spec_list, NULL) | |
4022 | == SPEC_DEFERRED) | |
5bab4c96 PT |
4023 | { |
4024 | gfc_error ("The type parameter spec list in the type-spec at " | |
d36eb6bf | 4025 | "%L cannot contain DEFERRED parameters", &old_locus); |
5bab4c96 PT |
4026 | goto cleanup; |
4027 | } | |
8c6a85e3 TB |
4028 | } |
4029 | else | |
4030 | { | |
4031 | ts.type = BT_UNKNOWN; | |
4032 | gfc_current_locus = old_locus; | |
eda0ed25 | 4033 | } |
6291f3ba | 4034 | } |
8de10a62 | 4035 | |
8c6a85e3 | 4036 | for (;;) |
6de9cd9a | 4037 | { |
8c6a85e3 TB |
4038 | if (head == NULL) |
4039 | head = tail = gfc_get_alloc (); | |
4040 | else | |
4041 | { | |
4042 | tail->next = gfc_get_alloc (); | |
4043 | tail = tail->next; | |
4044 | } | |
4045 | ||
4046 | m = gfc_match_variable (&tail->expr, 0); | |
6de9cd9a DN |
4047 | if (m == MATCH_NO) |
4048 | goto syntax; | |
4049 | if (m == MATCH_ERROR) | |
4050 | goto cleanup; | |
4051 | ||
8c6a85e3 TB |
4052 | if (gfc_check_do_variable (tail->expr->symtree)) |
4053 | goto cleanup; | |
6de9cd9a | 4054 | |
ccd7751b TB |
4055 | bool impure = gfc_impure_variable (tail->expr->symtree->n.sym); |
4056 | if (impure && gfc_pure (NULL)) | |
8c6a85e3 TB |
4057 | { |
4058 | gfc_error ("Bad allocate-object at %C for a PURE procedure"); | |
4059 | goto cleanup; | |
4060 | } | |
6de9cd9a | 4061 | |
ccd7751b TB |
4062 | if (impure) |
4063 | gfc_unset_implicit_pure (NULL); | |
6de9cd9a | 4064 | |
d36eb6bf SK |
4065 | /* F2008:C631 (R626) A type-param-value in a type-spec shall be an |
4066 | asterisk if and only if each allocate-object is a dummy argument | |
4067 | for which the corresponding type parameter is assumed. */ | |
4068 | if (saw_assumed | |
4069 | && (tail->expr->ts.deferred | |
4070 | || tail->expr->ts.u.cl->length | |
4071 | || tail->expr->symtree->n.sym->attr.dummy == 0)) | |
4072 | { | |
4073 | gfc_error ("Incompatible allocate-object at %C for CHARACTER " | |
4074 | "type-spec at %L", &assumed_locus); | |
4075 | goto cleanup; | |
4076 | } | |
4077 | ||
8c6a85e3 TB |
4078 | if (tail->expr->ts.deferred) |
4079 | { | |
4080 | saw_deferred = true; | |
4081 | deferred_locus = tail->expr->where; | |
4082 | } | |
6de9cd9a | 4083 | |
524af0d6 JB |
4084 | if (gfc_find_state (COMP_DO_CONCURRENT) |
4085 | || gfc_find_state (COMP_CRITICAL)) | |
8c6a85e3 TB |
4086 | { |
4087 | gfc_ref *ref; | |
4088 | bool coarray = tail->expr->symtree->n.sym->attr.codimension; | |
4089 | for (ref = tail->expr->ref; ref; ref = ref->next) | |
4090 | if (ref->type == REF_COMPONENT) | |
4091 | coarray = ref->u.c.component->attr.codimension; | |
6de9cd9a | 4092 | |
524af0d6 | 4093 | if (coarray && gfc_find_state (COMP_DO_CONCURRENT)) |
8c6a85e3 TB |
4094 | { |
4095 | gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block"); | |
4096 | goto cleanup; | |
4097 | } | |
524af0d6 | 4098 | if (coarray && gfc_find_state (COMP_CRITICAL)) |
8c6a85e3 TB |
4099 | { |
4100 | gfc_error ("ALLOCATE of coarray at %C in CRITICAL block"); | |
4101 | goto cleanup; | |
4102 | } | |
4103 | } | |
6de9cd9a | 4104 | |
98cf47d1 JW |
4105 | /* Check for F08:C628. */ |
4106 | sym = tail->expr->symtree->n.sym; | |
4107 | b1 = !(tail->expr->ref | |
4108 | && (tail->expr->ref->type == REF_COMPONENT | |
4109 | || tail->expr->ref->type == REF_ARRAY)); | |
4110 | if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok) | |
4111 | b2 = !(CLASS_DATA (sym)->attr.allocatable | |
4112 | || CLASS_DATA (sym)->attr.class_pointer); | |
4113 | else | |
4114 | b2 = sym && !(sym->attr.allocatable || sym->attr.pointer | |
4115 | || sym->attr.proc_pointer); | |
4116 | b3 = sym && sym->ns && sym->ns->proc_name | |
4117 | && (sym->ns->proc_name->attr.allocatable | |
4118 | || sym->ns->proc_name->attr.pointer | |
4119 | || sym->ns->proc_name->attr.proc_pointer); | |
4120 | if (b1 && b2 && !b3) | |
4121 | { | |
4122 | gfc_error ("Allocate-object at %L is neither a data pointer " | |
4123 | "nor an allocatable variable", &tail->expr->where); | |
4124 | goto cleanup; | |
4125 | } | |
4126 | ||
8c6a85e3 TB |
4127 | /* The ALLOCATE statement had an optional typespec. Check the |
4128 | constraints. */ | |
4129 | if (ts.type != BT_UNKNOWN) | |
6de9cd9a | 4130 | { |
8c6a85e3 TB |
4131 | /* Enforce F03:C624. */ |
4132 | if (!gfc_type_compatible (&tail->expr->ts, &ts)) | |
4133 | { | |
4134 | gfc_error ("Type of entity at %L is type incompatible with " | |
4135 | "typespec", &tail->expr->where); | |
4136 | goto cleanup; | |
4137 | } | |
6de9cd9a | 4138 | |
8c6a85e3 | 4139 | /* Enforce F03:C627. */ |
8b704316 | 4140 | if (ts.kind != tail->expr->ts.kind && !UNLIMITED_POLY (tail->expr)) |
8c6a85e3 TB |
4141 | { |
4142 | gfc_error ("Kind type parameter for entity at %L differs from " | |
4143 | "the kind type parameter of the typespec", | |
4144 | &tail->expr->where); | |
4145 | goto cleanup; | |
4146 | } | |
4147 | } | |
6de9cd9a | 4148 | |
8c6a85e3 TB |
4149 | if (tail->expr->ts.type == BT_DERIVED) |
4150 | tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived); | |
6de9cd9a | 4151 | |
5bab4c96 PT |
4152 | if (type_param_spec_list) |
4153 | tail->expr->param_list = gfc_copy_actual_arglist (type_param_spec_list); | |
4154 | ||
8b704316 PT |
4155 | saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr); |
4156 | ||
8c6a85e3 TB |
4157 | if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension) |
4158 | { | |
4159 | gfc_error ("Shape specification for allocatable scalar at %C"); | |
4160 | goto cleanup; | |
4161 | } | |
6de9cd9a | 4162 | |
8c6a85e3 TB |
4163 | if (gfc_match_char (',') != MATCH_YES) |
4164 | break; | |
4165 | ||
4166 | alloc_opt_list: | |
4167 | ||
4168 | m = gfc_match (" stat = %v", &tmp); | |
4169 | if (m == MATCH_ERROR) | |
4170 | goto cleanup; | |
4171 | if (m == MATCH_YES) | |
4172 | { | |
4173 | /* Enforce C630. */ | |
4174 | if (saw_stat) | |
4175 | { | |
2f029c08 | 4176 | gfc_error ("Redundant STAT tag found at %L", &tmp->where); |
8c6a85e3 TB |
4177 | goto cleanup; |
4178 | } | |
4179 | ||
4180 | stat = tmp; | |
4181 | tmp = NULL; | |
4182 | saw_stat = true; | |
4183 | ||
4184 | if (gfc_check_do_variable (stat->symtree)) | |
4185 | goto cleanup; | |
4186 | ||
4187 | if (gfc_match_char (',') == MATCH_YES) | |
4188 | goto alloc_opt_list; | |
4189 | } | |
4190 | ||
4191 | m = gfc_match (" errmsg = %v", &tmp); | |
4192 | if (m == MATCH_ERROR) | |
4193 | goto cleanup; | |
4194 | if (m == MATCH_YES) | |
4195 | { | |
524af0d6 | 4196 | if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG tag at %L", &tmp->where)) |
8c6a85e3 TB |
4197 | goto cleanup; |
4198 | ||
4199 | /* Enforce C630. */ | |
4200 | if (saw_errmsg) | |
4201 | { | |
2f029c08 | 4202 | gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); |
8c6a85e3 TB |
4203 | goto cleanup; |
4204 | } | |
4205 | ||
4206 | errmsg = tmp; | |
4207 | tmp = NULL; | |
4208 | saw_errmsg = true; | |
4209 | ||
4210 | if (gfc_match_char (',') == MATCH_YES) | |
4211 | goto alloc_opt_list; | |
4212 | } | |
4213 | ||
4214 | m = gfc_match (" source = %e", &tmp); | |
4215 | if (m == MATCH_ERROR) | |
4216 | goto cleanup; | |
4217 | if (m == MATCH_YES) | |
4218 | { | |
524af0d6 | 4219 | if (!gfc_notify_std (GFC_STD_F2003, "SOURCE tag at %L", &tmp->where)) |
8c6a85e3 TB |
4220 | goto cleanup; |
4221 | ||
4222 | /* Enforce C630. */ | |
4223 | if (saw_source) | |
4224 | { | |
2f029c08 | 4225 | gfc_error ("Redundant SOURCE tag found at %L", &tmp->where); |
8c6a85e3 TB |
4226 | goto cleanup; |
4227 | } | |
4228 | ||
4229 | /* The next 2 conditionals check C631. */ | |
4230 | if (ts.type != BT_UNKNOWN) | |
4231 | { | |
fea70c99 | 4232 | gfc_error ("SOURCE tag at %L conflicts with the typespec at %L", |
8c6a85e3 TB |
4233 | &tmp->where, &old_locus); |
4234 | goto cleanup; | |
4235 | } | |
4236 | ||
4cb2a867 | 4237 | if (head->next |
524af0d6 | 4238 | && !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L" |
5bab4c96 | 4239 | " with more than a single allocate object", |
524af0d6 | 4240 | &tmp->where)) |
4cb2a867 | 4241 | goto cleanup; |
8c6a85e3 TB |
4242 | |
4243 | source = tmp; | |
4244 | tmp = NULL; | |
4245 | saw_source = true; | |
4246 | ||
4247 | if (gfc_match_char (',') == MATCH_YES) | |
4248 | goto alloc_opt_list; | |
6de9cd9a | 4249 | } |
8c6a85e3 TB |
4250 | |
4251 | m = gfc_match (" mold = %e", &tmp); | |
4252 | if (m == MATCH_ERROR) | |
4253 | goto cleanup; | |
4254 | if (m == MATCH_YES) | |
4255 | { | |
524af0d6 | 4256 | if (!gfc_notify_std (GFC_STD_F2008, "MOLD tag at %L", &tmp->where)) |
8c6a85e3 TB |
4257 | goto cleanup; |
4258 | ||
4259 | /* Check F08:C636. */ | |
4260 | if (saw_mold) | |
4261 | { | |
2f029c08 | 4262 | gfc_error ("Redundant MOLD tag found at %L", &tmp->where); |
8c6a85e3 TB |
4263 | goto cleanup; |
4264 | } | |
8b704316 | 4265 | |
8c6a85e3 TB |
4266 | /* Check F08:C637. */ |
4267 | if (ts.type != BT_UNKNOWN) | |
4268 | { | |
fea70c99 | 4269 | gfc_error ("MOLD tag at %L conflicts with the typespec at %L", |
8c6a85e3 TB |
4270 | &tmp->where, &old_locus); |
4271 | goto cleanup; | |
4272 | } | |
4273 | ||
4274 | mold = tmp; | |
4275 | tmp = NULL; | |
4276 | saw_mold = true; | |
4277 | mold->mold = 1; | |
4278 | ||
4279 | if (gfc_match_char (',') == MATCH_YES) | |
4280 | goto alloc_opt_list; | |
4281 | } | |
4282 | ||
4283 | gfc_gobble_whitespace (); | |
4284 | ||
4285 | if (gfc_peek_char () == ')') | |
4286 | break; | |
6de9cd9a DN |
4287 | } |
4288 | ||
8c6a85e3 TB |
4289 | if (gfc_match (" )%t") != MATCH_YES) |
4290 | goto syntax; | |
4291 | ||
4292 | /* Check F08:C637. */ | |
4293 | if (source && mold) | |
4294 | { | |
fea70c99 MLI |
4295 | gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L", |
4296 | &mold->where, &source->where); | |
8c6a85e3 TB |
4297 | goto cleanup; |
4298 | } | |
4299 | ||
4300 | /* Check F03:C623, */ | |
4301 | if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold) | |
4302 | { | |
4303 | gfc_error ("Allocate-object at %L with a deferred type parameter " | |
4304 | "requires either a type-spec or SOURCE tag or a MOLD tag", | |
4305 | &deferred_locus); | |
4306 | goto cleanup; | |
4307 | } | |
8b704316 PT |
4308 | |
4309 | /* Check F03:C625, */ | |
4310 | if (saw_unlimited && ts.type == BT_UNKNOWN && !source && !mold) | |
4311 | { | |
4312 | for (tail = head; tail; tail = tail->next) | |
4313 | { | |
4314 | if (UNLIMITED_POLY (tail->expr)) | |
4315 | gfc_error ("Unlimited polymorphic allocate-object at %L " | |
4316 | "requires either a type-spec or SOURCE tag " | |
4317 | "or a MOLD tag", &tail->expr->where); | |
4318 | } | |
4319 | goto cleanup; | |
4320 | } | |
4321 | ||
8c6a85e3 TB |
4322 | new_st.op = EXEC_ALLOCATE; |
4323 | new_st.expr1 = stat; | |
4324 | new_st.expr2 = errmsg; | |
4325 | if (source) | |
4326 | new_st.expr3 = source; | |
4327 | else | |
4328 | new_st.expr3 = mold; | |
4329 | new_st.ext.alloc.list = head; | |
4330 | new_st.ext.alloc.ts = ts; | |
6de9cd9a | 4331 | |
5bab4c96 PT |
4332 | if (type_param_spec_list) |
4333 | gfc_free_actual_arglist (type_param_spec_list); | |
4334 | ||
6de9cd9a DN |
4335 | return MATCH_YES; |
4336 | ||
4337 | syntax: | |
8c6a85e3 | 4338 | gfc_syntax_error (ST_ALLOCATE); |
6de9cd9a DN |
4339 | |
4340 | cleanup: | |
8c6a85e3 TB |
4341 | gfc_free_expr (errmsg); |
4342 | gfc_free_expr (source); | |
4343 | gfc_free_expr (stat); | |
4344 | gfc_free_expr (mold); | |
4345 | if (tmp && tmp->expr_type) gfc_free_expr (tmp); | |
4346 | gfc_free_alloc_list (head); | |
5bab4c96 PT |
4347 | if (type_param_spec_list) |
4348 | gfc_free_actual_arglist (type_param_spec_list); | |
6de9cd9a DN |
4349 | return MATCH_ERROR; |
4350 | } | |
4351 | ||
4352 | ||
8c6a85e3 TB |
4353 | /* Match a NULLIFY statement. A NULLIFY statement is transformed into |
4354 | a set of pointer assignments to intrinsic NULL(). */ | |
9056bd70 | 4355 | |
8c6a85e3 TB |
4356 | match |
4357 | gfc_match_nullify (void) | |
9056bd70 | 4358 | { |
8c6a85e3 TB |
4359 | gfc_code *tail; |
4360 | gfc_expr *e, *p; | |
4361 | match m; | |
9056bd70 | 4362 | |
8c6a85e3 | 4363 | tail = NULL; |
53814b8f | 4364 | |
8c6a85e3 TB |
4365 | if (gfc_match_char ('(') != MATCH_YES) |
4366 | goto syntax; | |
9056bd70 | 4367 | |
8c6a85e3 | 4368 | for (;;) |
9056bd70 | 4369 | { |
8c6a85e3 TB |
4370 | m = gfc_match_variable (&p, 0); |
4371 | if (m == MATCH_ERROR) | |
4372 | goto cleanup; | |
4373 | if (m == MATCH_NO) | |
4374 | goto syntax; | |
4375 | ||
4376 | if (gfc_check_do_variable (p->symtree)) | |
4377 | goto cleanup; | |
4378 | ||
4379 | /* F2008, C1242. */ | |
4380 | if (gfc_is_coindexed (p)) | |
4381 | { | |
0c133211 | 4382 | gfc_error ("Pointer object at %C shall not be coindexed"); |
8c6a85e3 TB |
4383 | goto cleanup; |
4384 | } | |
4385 | ||
4386 | /* build ' => NULL() '. */ | |
4387 | e = gfc_get_null_expr (&gfc_current_locus); | |
4388 | ||
4389 | /* Chain to list. */ | |
4390 | if (tail == NULL) | |
11e5274a JW |
4391 | { |
4392 | tail = &new_st; | |
4393 | tail->op = EXEC_POINTER_ASSIGN; | |
4394 | } | |
8c6a85e3 TB |
4395 | else |
4396 | { | |
11e5274a | 4397 | tail->next = gfc_get_code (EXEC_POINTER_ASSIGN); |
8c6a85e3 TB |
4398 | tail = tail->next; |
4399 | } | |
4400 | ||
8c6a85e3 TB |
4401 | tail->expr1 = p; |
4402 | tail->expr2 = e; | |
4403 | ||
4404 | if (gfc_match (" )%t") == MATCH_YES) | |
4405 | break; | |
4406 | if (gfc_match_char (',') != MATCH_YES) | |
4407 | goto syntax; | |
9056bd70 TS |
4408 | } |
4409 | ||
8c6a85e3 TB |
4410 | return MATCH_YES; |
4411 | ||
4412 | syntax: | |
4413 | gfc_syntax_error (ST_NULLIFY); | |
4414 | ||
4415 | cleanup: | |
4416 | gfc_free_statements (new_st.next); | |
4417 | new_st.next = NULL; | |
4418 | gfc_free_expr (new_st.expr1); | |
4419 | new_st.expr1 = NULL; | |
4420 | gfc_free_expr (new_st.expr2); | |
4421 | new_st.expr2 = NULL; | |
4422 | return MATCH_ERROR; | |
9056bd70 TS |
4423 | } |
4424 | ||
4425 | ||
8c6a85e3 | 4426 | /* Match a DEALLOCATE statement. */ |
6de9cd9a | 4427 | |
8c6a85e3 TB |
4428 | match |
4429 | gfc_match_deallocate (void) | |
6de9cd9a | 4430 | { |
8c6a85e3 TB |
4431 | gfc_alloc *head, *tail; |
4432 | gfc_expr *stat, *errmsg, *tmp; | |
4433 | gfc_symbol *sym; | |
6de9cd9a | 4434 | match m; |
8c6a85e3 | 4435 | bool saw_stat, saw_errmsg, b1, b2; |
6de9cd9a | 4436 | |
8c6a85e3 TB |
4437 | head = tail = NULL; |
4438 | stat = errmsg = tmp = NULL; | |
4439 | saw_stat = saw_errmsg = false; | |
6de9cd9a | 4440 | |
8c6a85e3 TB |
4441 | if (gfc_match_char ('(') != MATCH_YES) |
4442 | goto syntax; | |
4443 | ||
4444 | for (;;) | |
6de9cd9a | 4445 | { |
8c6a85e3 TB |
4446 | if (head == NULL) |
4447 | head = tail = gfc_get_alloc (); | |
4448 | else | |
4449 | { | |
4450 | tail->next = gfc_get_alloc (); | |
4451 | tail = tail->next; | |
4452 | } | |
4453 | ||
4454 | m = gfc_match_variable (&tail->expr, 0); | |
4455 | if (m == MATCH_ERROR) | |
4456 | goto cleanup; | |
4457 | if (m == MATCH_NO) | |
4458 | goto syntax; | |
4459 | ||
4460 | if (gfc_check_do_variable (tail->expr->symtree)) | |
4461 | goto cleanup; | |
4462 | ||
4463 | sym = tail->expr->symtree->n.sym; | |
4464 | ||
ccd7751b TB |
4465 | bool impure = gfc_impure_variable (sym); |
4466 | if (impure && gfc_pure (NULL)) | |
8c6a85e3 TB |
4467 | { |
4468 | gfc_error ("Illegal allocate-object at %C for a PURE procedure"); | |
4469 | goto cleanup; | |
4470 | } | |
4471 | ||
ccd7751b TB |
4472 | if (impure) |
4473 | gfc_unset_implicit_pure (NULL); | |
8c6a85e3 TB |
4474 | |
4475 | if (gfc_is_coarray (tail->expr) | |
524af0d6 | 4476 | && gfc_find_state (COMP_DO_CONCURRENT)) |
8c6a85e3 TB |
4477 | { |
4478 | gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block"); | |
4479 | goto cleanup; | |
4480 | } | |
4481 | ||
4482 | if (gfc_is_coarray (tail->expr) | |
524af0d6 | 4483 | && gfc_find_state (COMP_CRITICAL)) |
8c6a85e3 TB |
4484 | { |
4485 | gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block"); | |
4486 | goto cleanup; | |
4487 | } | |
4488 | ||
4489 | /* FIXME: disable the checking on derived types. */ | |
4490 | b1 = !(tail->expr->ref | |
4491 | && (tail->expr->ref->type == REF_COMPONENT | |
4492 | || tail->expr->ref->type == REF_ARRAY)); | |
4493 | if (sym && sym->ts.type == BT_CLASS) | |
4494 | b2 = !(CLASS_DATA (sym)->attr.allocatable | |
4495 | || CLASS_DATA (sym)->attr.class_pointer); | |
4496 | else | |
4497 | b2 = sym && !(sym->attr.allocatable || sym->attr.pointer | |
4498 | || sym->attr.proc_pointer); | |
4499 | if (b1 && b2) | |
4500 | { | |
4501 | gfc_error ("Allocate-object at %C is not a nonprocedure pointer " | |
b59e9071 | 4502 | "nor an allocatable variable"); |
8c6a85e3 TB |
4503 | goto cleanup; |
4504 | } | |
4505 | ||
4506 | if (gfc_match_char (',') != MATCH_YES) | |
4507 | break; | |
4508 | ||
4509 | dealloc_opt_list: | |
4510 | ||
4511 | m = gfc_match (" stat = %v", &tmp); | |
4512 | if (m == MATCH_ERROR) | |
4513 | goto cleanup; | |
4514 | if (m == MATCH_YES) | |
4515 | { | |
4516 | if (saw_stat) | |
4517 | { | |
2f029c08 | 4518 | gfc_error ("Redundant STAT tag found at %L", &tmp->where); |
8c6a85e3 TB |
4519 | gfc_free_expr (tmp); |
4520 | goto cleanup; | |
4521 | } | |
4522 | ||
4523 | stat = tmp; | |
4524 | saw_stat = true; | |
4525 | ||
4526 | if (gfc_check_do_variable (stat->symtree)) | |
4527 | goto cleanup; | |
4528 | ||
4529 | if (gfc_match_char (',') == MATCH_YES) | |
4530 | goto dealloc_opt_list; | |
4531 | } | |
4532 | ||
4533 | m = gfc_match (" errmsg = %v", &tmp); | |
4534 | if (m == MATCH_ERROR) | |
4535 | goto cleanup; | |
4536 | if (m == MATCH_YES) | |
4537 | { | |
524af0d6 | 4538 | if (!gfc_notify_std (GFC_STD_F2003, "ERRMSG at %L", &tmp->where)) |
8c6a85e3 TB |
4539 | goto cleanup; |
4540 | ||
4541 | if (saw_errmsg) | |
4542 | { | |
2f029c08 | 4543 | gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where); |
8c6a85e3 TB |
4544 | gfc_free_expr (tmp); |
4545 | goto cleanup; | |
4546 | } | |
4547 | ||
4548 | errmsg = tmp; | |
4549 | saw_errmsg = true; | |
4550 | ||
4551 | if (gfc_match_char (',') == MATCH_YES) | |
4552 | goto dealloc_opt_list; | |
4553 | } | |
4554 | ||
4555 | gfc_gobble_whitespace (); | |
4556 | ||
4557 | if (gfc_peek_char () == ')') | |
4558 | break; | |
6de9cd9a DN |
4559 | } |
4560 | ||
8c6a85e3 TB |
4561 | if (gfc_match (" )%t") != MATCH_YES) |
4562 | goto syntax; | |
4563 | ||
4564 | new_st.op = EXEC_DEALLOCATE; | |
4565 | new_st.expr1 = stat; | |
4566 | new_st.expr2 = errmsg; | |
4567 | new_st.ext.alloc.list = head; | |
4568 | ||
4569 | return MATCH_YES; | |
6de9cd9a | 4570 | |
8c6a85e3 TB |
4571 | syntax: |
4572 | gfc_syntax_error (ST_DEALLOCATE); | |
6de9cd9a | 4573 | |
8c6a85e3 TB |
4574 | cleanup: |
4575 | gfc_free_expr (errmsg); | |
4576 | gfc_free_expr (stat); | |
4577 | gfc_free_alloc_list (head); | |
6de9cd9a DN |
4578 | return MATCH_ERROR; |
4579 | } | |
4580 | ||
4581 | ||
8c6a85e3 | 4582 | /* Match a RETURN statement. */ |
6de9cd9a DN |
4583 | |
4584 | match | |
8c6a85e3 | 4585 | gfc_match_return (void) |
6de9cd9a | 4586 | { |
8c6a85e3 | 4587 | gfc_expr *e; |
6de9cd9a | 4588 | match m; |
8c6a85e3 | 4589 | gfc_compile_state s; |
6de9cd9a | 4590 | |
8c6a85e3 TB |
4591 | e = NULL; |
4592 | ||
524af0d6 | 4593 | if (gfc_find_state (COMP_CRITICAL)) |
6de9cd9a | 4594 | { |
8c6a85e3 TB |
4595 | gfc_error ("Image control statement RETURN at %C in CRITICAL block"); |
4596 | return MATCH_ERROR; | |
6de9cd9a DN |
4597 | } |
4598 | ||
524af0d6 | 4599 | if (gfc_find_state (COMP_DO_CONCURRENT)) |
6de9cd9a | 4600 | { |
8c6a85e3 TB |
4601 | gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block"); |
4602 | return MATCH_ERROR; | |
4603 | } | |
f69ab0e0 | 4604 | |
8c6a85e3 TB |
4605 | if (gfc_match_eos () == MATCH_YES) |
4606 | goto done; | |
6de9cd9a | 4607 | |
524af0d6 | 4608 | if (!gfc_find_state (COMP_SUBROUTINE)) |
8c6a85e3 TB |
4609 | { |
4610 | gfc_error ("Alternate RETURN statement at %C is only allowed within " | |
4611 | "a SUBROUTINE"); | |
4612 | goto cleanup; | |
4613 | } | |
6de9cd9a | 4614 | |
8c6a85e3 TB |
4615 | if (gfc_current_form == FORM_FREE) |
4616 | { | |
4617 | /* The following are valid, so we can't require a blank after the | |
4618 | RETURN keyword: | |
4619 | return+1 | |
4620 | return(1) */ | |
4621 | char c = gfc_peek_ascii_char (); | |
4622 | if (ISALPHA (c) || ISDIGIT (c)) | |
4623 | return MATCH_NO; | |
4624 | } | |
6de9cd9a | 4625 | |
8c6a85e3 TB |
4626 | m = gfc_match (" %e%t", &e); |
4627 | if (m == MATCH_YES) | |
4628 | goto done; | |
4629 | if (m == MATCH_ERROR) | |
4630 | goto cleanup; | |
6de9cd9a | 4631 | |
8c6a85e3 | 4632 | gfc_syntax_error (ST_RETURN); |
6de9cd9a | 4633 | |
8c6a85e3 TB |
4634 | cleanup: |
4635 | gfc_free_expr (e); | |
4636 | return MATCH_ERROR; | |
6de9cd9a | 4637 | |
8c6a85e3 TB |
4638 | done: |
4639 | gfc_enclosing_unit (&s); | |
4640 | if (s == COMP_PROGRAM | |
524af0d6 JB |
4641 | && !gfc_notify_std (GFC_STD_GNU, "RETURN statement in " |
4642 | "main program at %C")) | |
8c6a85e3 | 4643 | return MATCH_ERROR; |
30aabb86 | 4644 | |
8c6a85e3 TB |
4645 | new_st.op = EXEC_RETURN; |
4646 | new_st.expr1 = e; | |
30aabb86 | 4647 | |
8c6a85e3 TB |
4648 | return MATCH_YES; |
4649 | } | |
30aabb86 | 4650 | |
30aabb86 | 4651 | |
8b704316 | 4652 | /* Match the call of a type-bound procedure, if CALL%var has already been |
8c6a85e3 | 4653 | matched and var found to be a derived-type variable. */ |
30aabb86 | 4654 | |
8c6a85e3 TB |
4655 | static match |
4656 | match_typebound_call (gfc_symtree* varst) | |
4657 | { | |
4658 | gfc_expr* base; | |
4659 | match m; | |
30aabb86 | 4660 | |
8c6a85e3 TB |
4661 | base = gfc_get_expr (); |
4662 | base->expr_type = EXPR_VARIABLE; | |
4663 | base->symtree = varst; | |
4664 | base->where = gfc_current_locus; | |
4665 | gfc_set_sym_referenced (varst->n.sym); | |
8b704316 | 4666 | |
8c6a85e3 TB |
4667 | m = gfc_match_varspec (base, 0, true, true); |
4668 | if (m == MATCH_NO) | |
4669 | gfc_error ("Expected component reference at %C"); | |
4670 | if (m != MATCH_YES) | |
36abe895 TB |
4671 | { |
4672 | gfc_free_expr (base); | |
4673 | return MATCH_ERROR; | |
4674 | } | |
6de9cd9a | 4675 | |
8c6a85e3 TB |
4676 | if (gfc_match_eos () != MATCH_YES) |
4677 | { | |
4678 | gfc_error ("Junk after CALL at %C"); | |
36abe895 | 4679 | gfc_free_expr (base); |
8c6a85e3 TB |
4680 | return MATCH_ERROR; |
4681 | } | |
30aabb86 | 4682 | |
8c6a85e3 TB |
4683 | if (base->expr_type == EXPR_COMPCALL) |
4684 | new_st.op = EXEC_COMPCALL; | |
4685 | else if (base->expr_type == EXPR_PPC) | |
4686 | new_st.op = EXEC_CALL_PPC; | |
4687 | else | |
4688 | { | |
4689 | gfc_error ("Expected type-bound procedure or procedure pointer component " | |
4690 | "at %C"); | |
36abe895 | 4691 | gfc_free_expr (base); |
8c6a85e3 | 4692 | return MATCH_ERROR; |
6de9cd9a | 4693 | } |
8c6a85e3 | 4694 | new_st.expr1 = base; |
6de9cd9a | 4695 | |
6de9cd9a | 4696 | return MATCH_YES; |
6de9cd9a DN |
4697 | } |
4698 | ||
4699 | ||
8c6a85e3 TB |
4700 | /* Match a CALL statement. The tricky part here are possible |
4701 | alternate return specifiers. We handle these by having all | |
4702 | "subroutines" actually return an integer via a register that gives | |
4703 | the return number. If the call specifies alternate returns, we | |
4704 | generate code for a SELECT statement whose case clauses contain | |
4705 | GOTOs to the various labels. */ | |
6de9cd9a DN |
4706 | |
4707 | match | |
8c6a85e3 | 4708 | gfc_match_call (void) |
6de9cd9a DN |
4709 | { |
4710 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
8c6a85e3 TB |
4711 | gfc_actual_arglist *a, *arglist; |
4712 | gfc_case *new_case; | |
6de9cd9a | 4713 | gfc_symbol *sym; |
8c6a85e3 TB |
4714 | gfc_symtree *st; |
4715 | gfc_code *c; | |
6de9cd9a | 4716 | match m; |
8c6a85e3 | 4717 | int i; |
6de9cd9a | 4718 | |
8c6a85e3 | 4719 | arglist = NULL; |
6de9cd9a | 4720 | |
8c6a85e3 TB |
4721 | m = gfc_match ("% %n", name); |
4722 | if (m == MATCH_NO) | |
4723 | goto syntax; | |
6de9cd9a | 4724 | if (m != MATCH_YES) |
8c6a85e3 | 4725 | return m; |
6de9cd9a | 4726 | |
8c6a85e3 | 4727 | if (gfc_get_ha_sym_tree (name, &st)) |
6de9cd9a DN |
4728 | return MATCH_ERROR; |
4729 | ||
8c6a85e3 | 4730 | sym = st->n.sym; |
6de9cd9a | 4731 | |
8c6a85e3 TB |
4732 | /* If this is a variable of derived-type, it probably starts a type-bound |
4733 | procedure call. */ | |
4734 | if ((sym->attr.flavor != FL_PROCEDURE | |
4735 | || gfc_is_function_return_value (sym, gfc_current_ns)) | |
4736 | && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)) | |
4737 | return match_typebound_call (st); | |
6de9cd9a | 4738 | |
8c6a85e3 TB |
4739 | /* If it does not seem to be callable (include functions so that the |
4740 | right association is made. They are thrown out in resolution.) | |
4741 | ... */ | |
4742 | if (!sym->attr.generic | |
4743 | && !sym->attr.subroutine | |
4744 | && !sym->attr.function) | |
4745 | { | |
4746 | if (!(sym->attr.external && !sym->attr.referenced)) | |
4747 | { | |
4748 | /* ...create a symbol in this scope... */ | |
4749 | if (sym->ns != gfc_current_ns | |
4750 | && gfc_get_sym_tree (name, NULL, &st, false) == 1) | |
4751 | return MATCH_ERROR; | |
6de9cd9a | 4752 | |
8c6a85e3 TB |
4753 | if (sym != st->n.sym) |
4754 | sym = st->n.sym; | |
4755 | } | |
6de9cd9a | 4756 | |
8c6a85e3 | 4757 | /* ...and then to try to make the symbol into a subroutine. */ |
524af0d6 | 4758 | if (!gfc_add_subroutine (&sym->attr, sym->name, NULL)) |
8c6a85e3 TB |
4759 | return MATCH_ERROR; |
4760 | } | |
6de9cd9a | 4761 | |
8c6a85e3 | 4762 | gfc_set_sym_referenced (sym); |
6de9cd9a | 4763 | |
8c6a85e3 | 4764 | if (gfc_match_eos () != MATCH_YES) |
6de9cd9a | 4765 | { |
8c6a85e3 TB |
4766 | m = gfc_match_actual_arglist (1, &arglist); |
4767 | if (m == MATCH_NO) | |
4768 | goto syntax; | |
4769 | if (m == MATCH_ERROR) | |
4770 | goto cleanup; | |
4771 | ||
4772 | if (gfc_match_eos () != MATCH_YES) | |
4773 | goto syntax; | |
6de9cd9a | 4774 | } |
6de9cd9a | 4775 | |
8c6a85e3 TB |
4776 | /* If any alternate return labels were found, construct a SELECT |
4777 | statement that will jump to the right place. */ | |
6de9cd9a | 4778 | |
8c6a85e3 TB |
4779 | i = 0; |
4780 | for (a = arglist; a; a = a->next) | |
4781 | if (a->expr == NULL) | |
502af491 PCC |
4782 | { |
4783 | i = 1; | |
4784 | break; | |
4785 | } | |
6de9cd9a | 4786 | |
8c6a85e3 TB |
4787 | if (i) |
4788 | { | |
4789 | gfc_symtree *select_st; | |
4790 | gfc_symbol *select_sym; | |
4791 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
6de9cd9a | 4792 | |
11e5274a | 4793 | new_st.next = c = gfc_get_code (EXEC_SELECT); |
8c6a85e3 TB |
4794 | sprintf (name, "_result_%s", sym->name); |
4795 | gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */ | |
6de9cd9a | 4796 | |
8c6a85e3 TB |
4797 | select_sym = select_st->n.sym; |
4798 | select_sym->ts.type = BT_INTEGER; | |
4799 | select_sym->ts.kind = gfc_default_integer_kind; | |
4800 | gfc_set_sym_referenced (select_sym); | |
4801 | c->expr1 = gfc_get_expr (); | |
4802 | c->expr1->expr_type = EXPR_VARIABLE; | |
4803 | c->expr1->symtree = select_st; | |
4804 | c->expr1->ts = select_sym->ts; | |
4805 | c->expr1->where = gfc_current_locus; | |
4806 | ||
4807 | i = 0; | |
4808 | for (a = arglist; a; a = a->next) | |
6de9cd9a | 4809 | { |
8c6a85e3 TB |
4810 | if (a->expr != NULL) |
4811 | continue; | |
6de9cd9a | 4812 | |
524af0d6 | 4813 | if (!gfc_reference_st_label (a->label, ST_LABEL_TARGET)) |
8c6a85e3 | 4814 | continue; |
e0e85e06 | 4815 | |
8c6a85e3 | 4816 | i++; |
6de9cd9a | 4817 | |
11e5274a | 4818 | c->block = gfc_get_code (EXEC_SELECT); |
8c6a85e3 | 4819 | c = c->block; |
6de9cd9a | 4820 | |
8c6a85e3 TB |
4821 | new_case = gfc_get_case (); |
4822 | new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i); | |
4823 | new_case->low = new_case->high; | |
4824 | c->ext.block.case_list = new_case; | |
6de9cd9a | 4825 | |
11e5274a | 4826 | c->next = gfc_get_code (EXEC_GOTO); |
8c6a85e3 TB |
4827 | c->next->label1 = a->label; |
4828 | } | |
4829 | } | |
e0e85e06 | 4830 | |
8c6a85e3 TB |
4831 | new_st.op = EXEC_CALL; |
4832 | new_st.symtree = st; | |
4833 | new_st.ext.actual = arglist; | |
6de9cd9a | 4834 | |
8c6a85e3 | 4835 | return MATCH_YES; |
6de9cd9a | 4836 | |
8c6a85e3 TB |
4837 | syntax: |
4838 | gfc_syntax_error (ST_CALL); | |
6de9cd9a | 4839 | |
8c6a85e3 TB |
4840 | cleanup: |
4841 | gfc_free_actual_arglist (arglist); | |
4842 | return MATCH_ERROR; | |
4843 | } | |
6de9cd9a | 4844 | |
6de9cd9a | 4845 | |
8c6a85e3 TB |
4846 | /* Given a name, return a pointer to the common head structure, |
4847 | creating it if it does not exist. If FROM_MODULE is nonzero, we | |
8b704316 | 4848 | mangle the name so that it doesn't interfere with commons defined |
8c6a85e3 TB |
4849 | in the using namespace. |
4850 | TODO: Add to global symbol tree. */ | |
4851 | ||
4852 | gfc_common_head * | |
4853 | gfc_get_common (const char *name, int from_module) | |
4854 | { | |
4855 | gfc_symtree *st; | |
4856 | static int serial = 0; | |
4857 | char mangled_name[GFC_MAX_SYMBOL_LEN + 1]; | |
4858 | ||
4859 | if (from_module) | |
4860 | { | |
4861 | /* A use associated common block is only needed to correctly layout | |
4862 | the variables it contains. */ | |
4863 | snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name); | |
4864 | st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name); | |
6de9cd9a | 4865 | } |
8c6a85e3 TB |
4866 | else |
4867 | { | |
4868 | st = gfc_find_symtree (gfc_current_ns->common_root, name); | |
6de9cd9a | 4869 | |
8c6a85e3 TB |
4870 | if (st == NULL) |
4871 | st = gfc_new_symtree (&gfc_current_ns->common_root, name); | |
4872 | } | |
6de9cd9a | 4873 | |
8c6a85e3 TB |
4874 | if (st->n.common == NULL) |
4875 | { | |
4876 | st->n.common = gfc_get_common_head (); | |
4877 | st->n.common->where = gfc_current_locus; | |
4878 | strcpy (st->n.common->name, name); | |
4879 | } | |
6de9cd9a | 4880 | |
8c6a85e3 | 4881 | return st->n.common; |
6de9cd9a DN |
4882 | } |
4883 | ||
4884 | ||
8c6a85e3 | 4885 | /* Match a common block name. */ |
6de9cd9a | 4886 | |
8c6a85e3 | 4887 | match match_common_name (char *name) |
6de9cd9a DN |
4888 | { |
4889 | match m; | |
4890 | ||
8c6a85e3 TB |
4891 | if (gfc_match_char ('/') == MATCH_NO) |
4892 | { | |
4893 | name[0] = '\0'; | |
4894 | return MATCH_YES; | |
4895 | } | |
6de9cd9a | 4896 | |
8c6a85e3 TB |
4897 | if (gfc_match_char ('/') == MATCH_YES) |
4898 | { | |
4899 | name[0] = '\0'; | |
4900 | return MATCH_YES; | |
4901 | } | |
6de9cd9a | 4902 | |
8c6a85e3 | 4903 | m = gfc_match_name (name); |
6de9cd9a | 4904 | |
8c6a85e3 TB |
4905 | if (m == MATCH_ERROR) |
4906 | return MATCH_ERROR; | |
4907 | if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES) | |
4908 | return MATCH_YES; | |
6de9cd9a | 4909 | |
8c6a85e3 TB |
4910 | gfc_error ("Syntax error in common block name at %C"); |
4911 | return MATCH_ERROR; | |
31fee91e MM |
4912 | } |
4913 | ||
4914 | ||
8c6a85e3 | 4915 | /* Match a COMMON statement. */ |
6de9cd9a DN |
4916 | |
4917 | match | |
8c6a85e3 | 4918 | gfc_match_common (void) |
6de9cd9a | 4919 | { |
2018f53e | 4920 | gfc_symbol *sym, **head, *tail, *other; |
8c6a85e3 TB |
4921 | char name[GFC_MAX_SYMBOL_LEN + 1]; |
4922 | gfc_common_head *t; | |
4923 | gfc_array_spec *as; | |
4924 | gfc_equiv *e1, *e2; | |
6de9cd9a DN |
4925 | match m; |
4926 | ||
8c6a85e3 | 4927 | as = NULL; |
6de9cd9a DN |
4928 | |
4929 | for (;;) | |
4930 | { | |
8c6a85e3 TB |
4931 | m = match_common_name (name); |
4932 | if (m == MATCH_ERROR) | |
4933 | goto cleanup; | |
6de9cd9a | 4934 | |
8c6a85e3 TB |
4935 | if (name[0] == '\0') |
4936 | { | |
4937 | t = &gfc_current_ns->blank_common; | |
4938 | if (t->head == NULL) | |
4939 | t->where = gfc_current_locus; | |
4940 | } | |
4941 | else | |
4942 | { | |
4943 | t = gfc_get_common (name, 0); | |
4944 | } | |
4945 | head = &t->head; | |
4946 | ||
4947 | if (*head == NULL) | |
4948 | tail = NULL; | |
4949 | else | |
4950 | { | |
4951 | tail = *head; | |
4952 | while (tail->common_next) | |
4953 | tail = tail->common_next; | |
4954 | } | |
6de9cd9a | 4955 | |
8c6a85e3 | 4956 | /* Grab the list of symbols. */ |
6de9cd9a DN |
4957 | for (;;) |
4958 | { | |
8c6a85e3 | 4959 | m = gfc_match_symbol (&sym, 0); |
6de9cd9a DN |
4960 | if (m == MATCH_ERROR) |
4961 | goto cleanup; | |
4962 | if (m == MATCH_NO) | |
4963 | goto syntax; | |
4964 | ||
8c6a85e3 TB |
4965 | /* See if we know the current common block is bind(c), and if |
4966 | so, then see if we can check if the symbol is (which it'll | |
4967 | need to be). This can happen if the bind(c) attr stmt was | |
4968 | applied to the common block, and the variable(s) already | |
4969 | defined, before declaring the common block. */ | |
4970 | if (t->is_bind_c == 1) | |
4971 | { | |
4972 | if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1) | |
4973 | { | |
4974 | /* If we find an error, just print it and continue, | |
4975 | cause it's just semantic, and we can see if there | |
4976 | are more errors. */ | |
fea70c99 MLI |
4977 | gfc_error_now ("Variable %qs at %L in common block %qs " |
4978 | "at %C must be declared with a C " | |
4979 | "interoperable kind since common block " | |
4980 | "%qs is bind(c)", | |
4981 | sym->name, &(sym->declared_at), t->name, | |
4982 | t->name); | |
8c6a85e3 | 4983 | } |
8b704316 | 4984 | |
8c6a85e3 | 4985 | if (sym->attr.is_bind_c == 1) |
4daa149b TB |
4986 | gfc_error_now ("Variable %qs in common block %qs at %C can not " |
4987 | "be bind(c) since it is not global", sym->name, | |
4988 | t->name); | |
8c6a85e3 | 4989 | } |
8b704316 | 4990 | |
8c6a85e3 | 4991 | if (sym->attr.in_common) |
e8ec07e1 | 4992 | { |
c4100eae | 4993 | gfc_error ("Symbol %qs at %C is already in a COMMON block", |
8c6a85e3 | 4994 | sym->name); |
e8ec07e1 PT |
4995 | goto cleanup; |
4996 | } | |
4997 | ||
8c6a85e3 TB |
4998 | if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL) |
4999 | || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA) | |
30aabb86 | 5000 | { |
a4d9b221 | 5001 | if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol %qs at " |
5bab4c96 | 5002 | "%C can only be COMMON in BLOCK DATA", |
524af0d6 | 5003 | sym->name)) |
30aabb86 | 5004 | goto cleanup; |
8c6a85e3 | 5005 | } |
6de9cd9a | 5006 | |
8c6a85e3 TB |
5007 | /* Deal with an optional array specification after the |
5008 | symbol name. */ | |
5009 | m = gfc_match_array_spec (&as, true, true); | |
5010 | if (m == MATCH_ERROR) | |
5011 | goto cleanup; | |
6de9cd9a | 5012 | |
8c6a85e3 TB |
5013 | if (m == MATCH_YES) |
5014 | { | |
5015 | if (as->type != AS_EXPLICIT) | |
5016 | { | |
a4d9b221 | 5017 | gfc_error ("Array specification for symbol %qs in COMMON " |
8c6a85e3 TB |
5018 | "at %C must be explicit", sym->name); |
5019 | goto cleanup; | |
5020 | } | |
b251af97 | 5021 | |
524af0d6 | 5022 | if (!gfc_add_dimension (&sym->attr, sym->name, NULL)) |
8c6a85e3 | 5023 | goto cleanup; |
d68bd5a8 | 5024 | |
8c6a85e3 TB |
5025 | if (sym->attr.pointer) |
5026 | { | |
a4d9b221 | 5027 | gfc_error ("Symbol %qs in COMMON at %C cannot be a " |
8c6a85e3 TB |
5028 | "POINTER array", sym->name); |
5029 | goto cleanup; | |
5030 | } | |
4213f93b | 5031 | |
8c6a85e3 TB |
5032 | sym->as = as; |
5033 | as = NULL; | |
4213f93b | 5034 | |
8c6a85e3 | 5035 | } |
9081e356 | 5036 | |
2b3f52a2 MM |
5037 | /* Add the in_common attribute, but ignore the reported errors |
5038 | if any, and continue matching. */ | |
5039 | gfc_add_in_common (&sym->attr, sym->name, NULL); | |
5040 | ||
a70ba41f MM |
5041 | sym->common_block = t; |
5042 | sym->common_block->refs++; | |
5043 | ||
5044 | if (tail != NULL) | |
5045 | tail->common_next = sym; | |
5046 | else | |
5047 | *head = sym; | |
5048 | ||
5049 | tail = sym; | |
5050 | ||
8c6a85e3 | 5051 | sym->common_head = t; |
4213f93b | 5052 | |
8c6a85e3 TB |
5053 | /* Check to see if the symbol is already in an equivalence group. |
5054 | If it is, set the other members as being in common. */ | |
5055 | if (sym->attr.in_equivalence) | |
5056 | { | |
5057 | for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next) | |
5058 | { | |
5059 | for (e2 = e1; e2; e2 = e2->eq) | |
5060 | if (e2->expr->symtree->n.sym == sym) | |
5061 | goto equiv_found; | |
4213f93b | 5062 | |
8c6a85e3 | 5063 | continue; |
d68bd5a8 | 5064 | |
8c6a85e3 | 5065 | equiv_found: |
4213f93b | 5066 | |
8c6a85e3 TB |
5067 | for (e2 = e1; e2; e2 = e2->eq) |
5068 | { | |
5069 | other = e2->expr->symtree->n.sym; | |
5070 | if (other->common_head | |
5071 | && other->common_head != sym->common_head) | |
5072 | { | |
a4d9b221 | 5073 | gfc_error ("Symbol %qs, in COMMON block %qs at " |
8c6a85e3 | 5074 | "%C is being indirectly equivalenced to " |
a4d9b221 | 5075 | "another COMMON block %qs", |
8c6a85e3 TB |
5076 | sym->name, sym->common_head->name, |
5077 | other->common_head->name); | |
5078 | goto cleanup; | |
5079 | } | |
5080 | other->attr.in_common = 1; | |
5081 | other->common_head = t; | |
5082 | } | |
5083 | } | |
5084 | } | |
d68bd5a8 | 5085 | |
4213f93b | 5086 | |
8c6a85e3 TB |
5087 | gfc_gobble_whitespace (); |
5088 | if (gfc_match_eos () == MATCH_YES) | |
5089 | goto done; | |
5090 | if (gfc_peek_ascii_char () == '/') | |
5091 | break; | |
5092 | if (gfc_match_char (',') != MATCH_YES) | |
5093 | goto syntax; | |
5094 | gfc_gobble_whitespace (); | |
5095 | if (gfc_peek_ascii_char () == '/') | |
5096 | break; | |
5097 | } | |
4213f93b PT |
5098 | } |
5099 | ||
8c6a85e3 TB |
5100 | done: |
5101 | return MATCH_YES; | |
4213f93b | 5102 | |
8c6a85e3 TB |
5103 | syntax: |
5104 | gfc_syntax_error (ST_COMMON); | |
4213f93b | 5105 | |
8c6a85e3 | 5106 | cleanup: |
8c6a85e3 TB |
5107 | gfc_free_array_spec (as); |
5108 | return MATCH_ERROR; | |
4213f93b PT |
5109 | } |
5110 | ||
6de9cd9a | 5111 | |
8c6a85e3 | 5112 | /* Match a BLOCK DATA program unit. */ |
6de9cd9a DN |
5113 | |
5114 | match | |
8c6a85e3 | 5115 | gfc_match_block_data (void) |
6de9cd9a | 5116 | { |
8c6a85e3 | 5117 | char name[GFC_MAX_SYMBOL_LEN + 1]; |
6de9cd9a | 5118 | gfc_symbol *sym; |
6de9cd9a DN |
5119 | match m; |
5120 | ||
8c6a85e3 TB |
5121 | if (gfc_match_eos () == MATCH_YES) |
5122 | { | |
5123 | gfc_new_block = NULL; | |
5124 | return MATCH_YES; | |
5125 | } | |
5126 | ||
5127 | m = gfc_match ("% %n%t", name); | |
6de9cd9a | 5128 | if (m != MATCH_YES) |
8c6a85e3 | 5129 | return MATCH_ERROR; |
6de9cd9a | 5130 | |
8c6a85e3 TB |
5131 | if (gfc_get_symbol (name, NULL, &sym)) |
5132 | return MATCH_ERROR; | |
6de9cd9a | 5133 | |
524af0d6 | 5134 | if (!gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL)) |
8c6a85e3 | 5135 | return MATCH_ERROR; |
6de9cd9a | 5136 | |
8c6a85e3 | 5137 | gfc_new_block = sym; |
6de9cd9a | 5138 | |
8c6a85e3 TB |
5139 | return MATCH_YES; |
5140 | } | |
d71b89ca | 5141 | |
6de9cd9a | 5142 | |
8c6a85e3 | 5143 | /* Free a namelist structure. */ |
4213f93b | 5144 | |
8c6a85e3 TB |
5145 | void |
5146 | gfc_free_namelist (gfc_namelist *name) | |
5147 | { | |
5148 | gfc_namelist *n; | |
6de9cd9a | 5149 | |
8c6a85e3 TB |
5150 | for (; name; name = n) |
5151 | { | |
5152 | n = name->next; | |
5153 | free (name); | |
5154 | } | |
5155 | } | |
e2ab8b09 | 5156 | |
6de9cd9a | 5157 | |
dd2fc525 JJ |
5158 | /* Free an OpenMP namelist structure. */ |
5159 | ||
5160 | void | |
5161 | gfc_free_omp_namelist (gfc_omp_namelist *name) | |
5162 | { | |
5163 | gfc_omp_namelist *n; | |
5164 | ||
5165 | for (; name; name = n) | |
5166 | { | |
5167 | gfc_free_expr (name->expr); | |
b46ebd6c JJ |
5168 | if (name->udr) |
5169 | { | |
5170 | if (name->udr->combiner) | |
5171 | gfc_free_statement (name->udr->combiner); | |
5172 | if (name->udr->initializer) | |
5173 | gfc_free_statement (name->udr->initializer); | |
5174 | free (name->udr); | |
5175 | } | |
dd2fc525 JJ |
5176 | n = name->next; |
5177 | free (name); | |
5178 | } | |
5179 | } | |
5180 | ||
5181 | ||
8c6a85e3 | 5182 | /* Match a NAMELIST statement. */ |
6de9cd9a | 5183 | |
8c6a85e3 TB |
5184 | match |
5185 | gfc_match_namelist (void) | |
5186 | { | |
5187 | gfc_symbol *group_name, *sym; | |
5188 | gfc_namelist *nl; | |
5189 | match m, m2; | |
6de9cd9a | 5190 | |
8c6a85e3 TB |
5191 | m = gfc_match (" / %s /", &group_name); |
5192 | if (m == MATCH_NO) | |
5193 | goto syntax; | |
5194 | if (m == MATCH_ERROR) | |
5195 | goto error; | |
6de9cd9a | 5196 | |
8c6a85e3 TB |
5197 | for (;;) |
5198 | { | |
5199 | if (group_name->ts.type != BT_UNKNOWN) | |
5200 | { | |
a4d9b221 | 5201 | gfc_error ("Namelist group name %qs at %C already has a basic " |
8c6a85e3 TB |
5202 | "type of %s", group_name->name, |
5203 | gfc_typename (&group_name->ts)); | |
5204 | return MATCH_ERROR; | |
5205 | } | |
6de9cd9a | 5206 | |
8c6a85e3 TB |
5207 | if (group_name->attr.flavor == FL_NAMELIST |
5208 | && group_name->attr.use_assoc | |
a4d9b221 | 5209 | && !gfc_notify_std (GFC_STD_GNU, "Namelist group name %qs " |
524af0d6 JB |
5210 | "at %C already is USE associated and can" |
5211 | "not be respecified.", group_name->name)) | |
8c6a85e3 | 5212 | return MATCH_ERROR; |
6de9cd9a | 5213 | |
8c6a85e3 | 5214 | if (group_name->attr.flavor != FL_NAMELIST |
5bab4c96 | 5215 | && !gfc_add_flavor (&group_name->attr, FL_NAMELIST, |
524af0d6 | 5216 | group_name->name, NULL)) |
8c6a85e3 | 5217 | return MATCH_ERROR; |
6de9cd9a | 5218 | |
8c6a85e3 TB |
5219 | for (;;) |
5220 | { | |
5221 | m = gfc_match_symbol (&sym, 1); | |
5222 | if (m == MATCH_NO) | |
5223 | goto syntax; | |
5224 | if (m == MATCH_ERROR) | |
5225 | goto error; | |
6de9cd9a | 5226 | |
8c6a85e3 | 5227 | if (sym->attr.in_namelist == 0 |
524af0d6 | 5228 | && !gfc_add_in_namelist (&sym->attr, sym->name, NULL)) |
8c6a85e3 | 5229 | goto error; |
6de9cd9a | 5230 | |
8c6a85e3 TB |
5231 | /* Use gfc_error_check here, rather than goto error, so that |
5232 | these are the only errors for the next two lines. */ | |
5233 | if (sym->as && sym->as->type == AS_ASSUMED_SIZE) | |
5234 | { | |
a4d9b221 | 5235 | gfc_error ("Assumed size array %qs in namelist %qs at " |
8c6a85e3 TB |
5236 | "%C is not allowed", sym->name, group_name->name); |
5237 | gfc_error_check (); | |
5238 | } | |
6de9cd9a | 5239 | |
8c6a85e3 TB |
5240 | nl = gfc_get_namelist (); |
5241 | nl->sym = sym; | |
5242 | sym->refs++; | |
6de9cd9a | 5243 | |
8c6a85e3 TB |
5244 | if (group_name->namelist == NULL) |
5245 | group_name->namelist = group_name->namelist_tail = nl; | |
5246 | else | |
5247 | { | |
5248 | group_name->namelist_tail->next = nl; | |
5249 | group_name->namelist_tail = nl; | |
5250 | } | |
6de9cd9a | 5251 | |
8c6a85e3 TB |
5252 | if (gfc_match_eos () == MATCH_YES) |
5253 | goto done; | |
6de9cd9a | 5254 | |
8c6a85e3 | 5255 | m = gfc_match_char (','); |
6de9cd9a | 5256 | |
8c6a85e3 TB |
5257 | if (gfc_match_char ('/') == MATCH_YES) |
5258 | { | |
5259 | m2 = gfc_match (" %s /", &group_name); | |
5260 | if (m2 == MATCH_YES) | |
5261 | break; | |
5262 | if (m2 == MATCH_ERROR) | |
5263 | goto error; | |
5264 | goto syntax; | |
5265 | } | |
6de9cd9a | 5266 | |
8c6a85e3 TB |
5267 | if (m != MATCH_YES) |
5268 | goto syntax; | |
6de9cd9a DN |
5269 | } |
5270 | } | |
5271 | ||
8c6a85e3 | 5272 | done: |
6de9cd9a DN |
5273 | return MATCH_YES; |
5274 | ||
8c6a85e3 TB |
5275 | syntax: |
5276 | gfc_syntax_error (ST_NAMELIST); | |
6de9cd9a | 5277 | |
8c6a85e3 | 5278 | error: |
6de9cd9a DN |
5279 | return MATCH_ERROR; |
5280 | } | |
5281 | ||
5282 | ||
8c6a85e3 | 5283 | /* Match a MODULE statement. */ |
6de9cd9a | 5284 | |
8c6a85e3 TB |
5285 | match |
5286 | gfc_match_module (void) | |
6de9cd9a | 5287 | { |
6de9cd9a DN |
5288 | match m; |
5289 | ||
8c6a85e3 | 5290 | m = gfc_match (" %s%t", &gfc_new_block); |
6de9cd9a DN |
5291 | if (m != MATCH_YES) |
5292 | return m; | |
5293 | ||
5bab4c96 | 5294 | if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, |
524af0d6 | 5295 | gfc_new_block->name, NULL)) |
8c6a85e3 | 5296 | return MATCH_ERROR; |
6de9cd9a | 5297 | |
8c6a85e3 | 5298 | return MATCH_YES; |
6de9cd9a DN |
5299 | } |
5300 | ||
5301 | ||
8c6a85e3 TB |
5302 | /* Free equivalence sets and lists. Recursively is the easiest way to |
5303 | do this. */ | |
6de9cd9a | 5304 | |
8c6a85e3 TB |
5305 | void |
5306 | gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop) | |
6de9cd9a | 5307 | { |
8c6a85e3 TB |
5308 | if (eq == stop) |
5309 | return; | |
6de9cd9a | 5310 | |
8c6a85e3 TB |
5311 | gfc_free_equiv (eq->eq); |
5312 | gfc_free_equiv_until (eq->next, stop); | |
5313 | gfc_free_expr (eq->expr); | |
5314 | free (eq); | |
5315 | } | |
6de9cd9a | 5316 | |
6de9cd9a | 5317 | |
8c6a85e3 TB |
5318 | void |
5319 | gfc_free_equiv (gfc_equiv *eq) | |
5320 | { | |
5321 | gfc_free_equiv_until (eq, NULL); | |
6de9cd9a DN |
5322 | } |
5323 | ||
5324 | ||
8c6a85e3 | 5325 | /* Match an EQUIVALENCE statement. */ |
7431bf06 | 5326 | |
8c6a85e3 TB |
5327 | match |
5328 | gfc_match_equivalence (void) | |
7431bf06 | 5329 | { |
8c6a85e3 TB |
5330 | gfc_equiv *eq, *set, *tail; |
5331 | gfc_ref *ref; | |
5332 | gfc_symbol *sym; | |
5333 | match m; | |
5334 | gfc_common_head *common_head = NULL; | |
5335 | bool common_flag; | |
5336 | int cnt; | |
7431bf06 | 5337 | |
8c6a85e3 | 5338 | tail = NULL; |
7431bf06 | 5339 | |
8c6a85e3 TB |
5340 | for (;;) |
5341 | { | |
5342 | eq = gfc_get_equiv (); | |
5343 | if (tail == NULL) | |
5344 | tail = eq; | |
7431bf06 | 5345 | |
8c6a85e3 TB |
5346 | eq->next = gfc_current_ns->equiv; |
5347 | gfc_current_ns->equiv = eq; | |
7431bf06 | 5348 | |
8c6a85e3 TB |
5349 | if (gfc_match_char ('(') != MATCH_YES) |
5350 | goto syntax; | |
7431bf06 | 5351 | |
8c6a85e3 TB |
5352 | set = eq; |
5353 | common_flag = FALSE; | |
5354 | cnt = 0; | |
7431bf06 | 5355 | |
8c6a85e3 TB |
5356 | for (;;) |
5357 | { | |
5358 | m = gfc_match_equiv_variable (&set->expr); | |
5359 | if (m == MATCH_ERROR) | |
5360 | goto cleanup; | |
5361 | if (m == MATCH_NO) | |
5362 | goto syntax; | |
3e78238a | 5363 | |
8c6a85e3 TB |
5364 | /* count the number of objects. */ |
5365 | cnt++; | |
5366 | ||
5367 | if (gfc_match_char ('%') == MATCH_YES) | |
5368 | { | |
5369 | gfc_error ("Derived type component %C is not a " | |
5370 | "permitted EQUIVALENCE member"); | |
5371 | goto cleanup; | |
5372 | } | |
7431bf06 | 5373 | |
8c6a85e3 TB |
5374 | for (ref = set->expr->ref; ref; ref = ref->next) |
5375 | if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) | |
5376 | { | |
5377 | gfc_error ("Array reference in EQUIVALENCE at %C cannot " | |
5378 | "be an array section"); | |
5379 | goto cleanup; | |
5380 | } | |
7431bf06 | 5381 | |
8c6a85e3 | 5382 | sym = set->expr->symtree->n.sym; |
cf2b3c22 | 5383 | |
524af0d6 | 5384 | if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL)) |
8c6a85e3 | 5385 | goto cleanup; |
cf2b3c22 | 5386 | |
8c6a85e3 TB |
5387 | if (sym->attr.in_common) |
5388 | { | |
5389 | common_flag = TRUE; | |
5390 | common_head = sym->common_head; | |
5391 | } | |
5392 | ||
5393 | if (gfc_match_char (')') == MATCH_YES) | |
5394 | break; | |
cf2b3c22 | 5395 | |
8c6a85e3 TB |
5396 | if (gfc_match_char (',') != MATCH_YES) |
5397 | goto syntax; | |
cf2b3c22 | 5398 | |
8c6a85e3 TB |
5399 | set->eq = gfc_get_equiv (); |
5400 | set = set->eq; | |
5401 | } | |
93d76687 | 5402 | |
8c6a85e3 | 5403 | if (cnt < 2) |
bc382218 | 5404 | { |
8c6a85e3 | 5405 | gfc_error ("EQUIVALENCE at %C requires two or more objects"); |
bc382218 JW |
5406 | goto cleanup; |
5407 | } | |
cf2b3c22 | 5408 | |
8c6a85e3 TB |
5409 | /* If one of the members of an equivalence is in common, then |
5410 | mark them all as being in common. Before doing this, check | |
5411 | that members of the equivalence group are not in different | |
5412 | common blocks. */ | |
5413 | if (common_flag) | |
5414 | for (set = eq; set; set = set->eq) | |
5415 | { | |
5416 | sym = set->expr->symtree->n.sym; | |
5417 | if (sym->common_head && sym->common_head != common_head) | |
5418 | { | |
5419 | gfc_error ("Attempt to indirectly overlap COMMON " | |
5420 | "blocks %s and %s by EQUIVALENCE at %C", | |
5421 | sym->common_head->name, common_head->name); | |
5422 | goto cleanup; | |
5423 | } | |
5424 | sym->attr.in_common = 1; | |
5425 | sym->common_head = common_head; | |
5426 | } | |
cf2b3c22 | 5427 | |
8c6a85e3 TB |
5428 | if (gfc_match_eos () == MATCH_YES) |
5429 | break; | |
5430 | if (gfc_match_char (',') != MATCH_YES) | |
5431 | { | |
5432 | gfc_error ("Expecting a comma in EQUIVALENCE at %C"); | |
5433 | goto cleanup; | |
5434 | } | |
cf2b3c22 TB |
5435 | } |
5436 | ||
8c6a85e3 | 5437 | return MATCH_YES; |
cf2b3c22 | 5438 | |
8c6a85e3 TB |
5439 | syntax: |
5440 | gfc_syntax_error (ST_EQUIVALENCE); | |
cf2b3c22 | 5441 | |
bc382218 | 5442 | cleanup: |
8c6a85e3 TB |
5443 | eq = tail->next; |
5444 | tail->next = NULL; | |
5445 | ||
5446 | gfc_free_equiv (gfc_current_ns->equiv); | |
5447 | gfc_current_ns->equiv = eq; | |
5448 | ||
5449 | return MATCH_ERROR; | |
cf2b3c22 TB |
5450 | } |
5451 | ||
5452 | ||
8c6a85e3 TB |
5453 | /* Check that a statement function is not recursive. This is done by looking |
5454 | for the statement function symbol(sym) by looking recursively through its | |
8b704316 | 5455 | expression(e). If a reference to sym is found, true is returned. |
8c6a85e3 TB |
5456 | 12.5.4 requires that any variable of function that is implicitly typed |
5457 | shall have that type confirmed by any subsequent type declaration. The | |
5458 | implicit typing is conveniently done here. */ | |
5459 | static bool | |
5460 | recursive_stmt_fcn (gfc_expr *, gfc_symbol *); | |
6de9cd9a | 5461 | |
8c6a85e3 TB |
5462 | static bool |
5463 | check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED) | |
6de9cd9a | 5464 | { |
6de9cd9a | 5465 | |
8c6a85e3 TB |
5466 | if (e == NULL) |
5467 | return false; | |
6de9cd9a | 5468 | |
8c6a85e3 | 5469 | switch (e->expr_type) |
6de9cd9a | 5470 | { |
8c6a85e3 TB |
5471 | case EXPR_FUNCTION: |
5472 | if (e->symtree == NULL) | |
5473 | return false; | |
6de9cd9a | 5474 | |
8c6a85e3 TB |
5475 | /* Check the name before testing for nested recursion! */ |
5476 | if (sym->name == e->symtree->n.sym->name) | |
5477 | return true; | |
6de9cd9a | 5478 | |
8c6a85e3 TB |
5479 | /* Catch recursion via other statement functions. */ |
5480 | if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION | |
5481 | && e->symtree->n.sym->value | |
5482 | && recursive_stmt_fcn (e->symtree->n.sym->value, sym)) | |
5483 | return true; | |
6de9cd9a | 5484 | |
8c6a85e3 TB |
5485 | if (e->symtree->n.sym->ts.type == BT_UNKNOWN) |
5486 | gfc_set_default_type (e->symtree->n.sym, 0, NULL); | |
6de9cd9a | 5487 | |
8c6a85e3 | 5488 | break; |
6de9cd9a | 5489 | |
8c6a85e3 TB |
5490 | case EXPR_VARIABLE: |
5491 | if (e->symtree && sym->name == e->symtree->n.sym->name) | |
5492 | return true; | |
6de9cd9a | 5493 | |
8c6a85e3 TB |
5494 | if (e->symtree->n.sym->ts.type == BT_UNKNOWN) |
5495 | gfc_set_default_type (e->symtree->n.sym, 0, NULL); | |
5496 | break; | |
6de9cd9a | 5497 | |
8c6a85e3 TB |
5498 | default: |
5499 | break; | |
6de9cd9a DN |
5500 | } |
5501 | ||
8c6a85e3 TB |
5502 | return false; |
5503 | } | |
6de9cd9a | 5504 | |
6de9cd9a | 5505 | |
8c6a85e3 TB |
5506 | static bool |
5507 | recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) | |
5508 | { | |
5509 | return gfc_traverse_expr (e, sym, check_stmt_fcn, 0); | |
6de9cd9a DN |
5510 | } |
5511 | ||
cf2b3c22 | 5512 | |
8c6a85e3 TB |
5513 | /* Match a statement function declaration. It is so easy to match |
5514 | non-statement function statements with a MATCH_ERROR as opposed to | |
5515 | MATCH_NO that we suppress error message in most cases. */ | |
cf2b3c22 TB |
5516 | |
5517 | match | |
8c6a85e3 | 5518 | gfc_match_st_function (void) |
cf2b3c22 | 5519 | { |
fea70c99 | 5520 | gfc_error_buffer old_error; |
8c6a85e3 TB |
5521 | gfc_symbol *sym; |
5522 | gfc_expr *expr; | |
cf2b3c22 | 5523 | match m; |
cf2b3c22 | 5524 | |
8c6a85e3 TB |
5525 | m = gfc_match_symbol (&sym, 0); |
5526 | if (m != MATCH_YES) | |
5527 | return m; | |
5528 | ||
fea70c99 | 5529 | gfc_push_error (&old_error); |
8c6a85e3 | 5530 | |
524af0d6 | 5531 | if (!gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, sym->name, NULL)) |
8c6a85e3 TB |
5532 | goto undo_error; |
5533 | ||
5534 | if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES) | |
5535 | goto undo_error; | |
5536 | ||
5537 | m = gfc_match (" = %e%t", &expr); | |
5538 | if (m == MATCH_NO) | |
5539 | goto undo_error; | |
5540 | ||
fea70c99 | 5541 | gfc_free_error (&old_error); |
c4100eae | 5542 | |
8c6a85e3 TB |
5543 | if (m == MATCH_ERROR) |
5544 | return m; | |
5545 | ||
5546 | if (recursive_stmt_fcn (expr, sym)) | |
cf2b3c22 | 5547 | { |
8c6a85e3 | 5548 | gfc_error ("Statement function at %L is recursive", &expr->where); |
cf2b3c22 TB |
5549 | return MATCH_ERROR; |
5550 | } | |
5551 | ||
8c6a85e3 | 5552 | sym->value = expr; |
cf2b3c22 | 5553 | |
5f0ba745 SK |
5554 | if ((gfc_current_state () == COMP_FUNCTION |
5555 | || gfc_current_state () == COMP_SUBROUTINE) | |
5556 | && gfc_state_stack->previous->state == COMP_INTERFACE) | |
5557 | { | |
5558 | gfc_error ("Statement function at %L cannot appear within an INTERFACE", | |
5559 | &expr->where); | |
5560 | return MATCH_ERROR; | |
5561 | } | |
5562 | ||
524af0d6 | 5563 | if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C")) |
8c6a85e3 | 5564 | return MATCH_ERROR; |
cf2b3c22 | 5565 | |
8c6a85e3 | 5566 | return MATCH_YES; |
cf2b3c22 | 5567 | |
8c6a85e3 | 5568 | undo_error: |
fea70c99 | 5569 | gfc_pop_error (&old_error); |
8c6a85e3 TB |
5570 | return MATCH_NO; |
5571 | } | |
cf2b3c22 | 5572 | |
cf2b3c22 | 5573 | |
79124116 PT |
5574 | /* Match an assignment to a pointer function (F2008). This could, in |
5575 | general be ambiguous with a statement function. In this implementation | |
5576 | it remains so if it is the first statement after the specification | |
5577 | block. */ | |
5578 | ||
5579 | match | |
5580 | gfc_match_ptr_fcn_assign (void) | |
5581 | { | |
5582 | gfc_error_buffer old_error; | |
5583 | locus old_loc; | |
5584 | gfc_symbol *sym; | |
5585 | gfc_expr *expr; | |
5586 | match m; | |
5587 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
5588 | ||
5589 | old_loc = gfc_current_locus; | |
5590 | m = gfc_match_name (name); | |
5591 | if (m != MATCH_YES) | |
5592 | return m; | |
5593 | ||
5594 | gfc_find_symbol (name, NULL, 1, &sym); | |
5595 | if (sym && sym->attr.flavor != FL_PROCEDURE) | |
5596 | return MATCH_NO; | |
5597 | ||
5598 | gfc_push_error (&old_error); | |
5599 | ||
5600 | if (sym && sym->attr.function) | |
5601 | goto match_actual_arglist; | |
5602 | ||
5603 | gfc_current_locus = old_loc; | |
5604 | m = gfc_match_symbol (&sym, 0); | |
5605 | if (m != MATCH_YES) | |
5606 | return m; | |
5607 | ||
5608 | if (!gfc_add_procedure (&sym->attr, PROC_UNKNOWN, sym->name, NULL)) | |
5609 | goto undo_error; | |
5610 | ||
5611 | match_actual_arglist: | |
5612 | gfc_current_locus = old_loc; | |
5613 | m = gfc_match (" %e", &expr); | |
5614 | if (m != MATCH_YES) | |
5615 | goto undo_error; | |
5616 | ||
5617 | new_st.op = EXEC_ASSIGN; | |
5618 | new_st.expr1 = expr; | |
5619 | expr = NULL; | |
5620 | ||
5621 | m = gfc_match (" = %e%t", &expr); | |
5622 | if (m != MATCH_YES) | |
5623 | goto undo_error; | |
5624 | ||
5625 | new_st.expr2 = expr; | |
5626 | return MATCH_YES; | |
5627 | ||
5628 | undo_error: | |
5629 | gfc_pop_error (&old_error); | |
5630 | return MATCH_NO; | |
5631 | } | |
5632 | ||
5633 | ||
8c6a85e3 TB |
5634 | /***************** SELECT CASE subroutines ******************/ |
5635 | ||
5636 | /* Free a single case structure. */ | |
5637 | ||
5638 | static void | |
5639 | free_case (gfc_case *p) | |
5640 | { | |
5641 | if (p->low == p->high) | |
5642 | p->high = NULL; | |
5643 | gfc_free_expr (p->low); | |
5644 | gfc_free_expr (p->high); | |
5645 | free (p); | |
5646 | } | |
cf2b3c22 | 5647 | |
cf2b3c22 | 5648 | |
8c6a85e3 | 5649 | /* Free a list of case structures. */ |
cf2b3c22 | 5650 | |
8c6a85e3 TB |
5651 | void |
5652 | gfc_free_case_list (gfc_case *p) | |
5653 | { | |
5654 | gfc_case *q; | |
cf2b3c22 | 5655 | |
8c6a85e3 TB |
5656 | for (; p; p = q) |
5657 | { | |
5658 | q = p->next; | |
5659 | free_case (p); | |
5660 | } | |
cf2b3c22 TB |
5661 | } |
5662 | ||
5663 | ||
727cde64 SK |
5664 | /* Match a single case selector. Combining the requirements of F08:C830 |
5665 | and F08:C832 (R838) means that the case-value must have either CHARACTER, | |
5666 | INTEGER, or LOGICAL type. */ | |
cf2b3c22 | 5667 | |
8c6a85e3 TB |
5668 | static match |
5669 | match_case_selector (gfc_case **cp) | |
cf2b3c22 | 5670 | { |
8c6a85e3 | 5671 | gfc_case *c; |
cf2b3c22 TB |
5672 | match m; |
5673 | ||
8c6a85e3 TB |
5674 | c = gfc_get_case (); |
5675 | c->where = gfc_current_locus; | |
cf2b3c22 | 5676 | |
8c6a85e3 | 5677 | if (gfc_match_char (':') == MATCH_YES) |
cf2b3c22 | 5678 | { |
8c6a85e3 | 5679 | m = gfc_match_init_expr (&c->high); |
cf2b3c22 | 5680 | if (m == MATCH_NO) |
8c6a85e3 TB |
5681 | goto need_expr; |
5682 | if (m == MATCH_ERROR) | |
5683 | goto cleanup; | |
727cde64 SK |
5684 | |
5685 | if (c->high->ts.type != BT_LOGICAL && c->high->ts.type != BT_INTEGER | |
5686 | && c->high->ts.type != BT_CHARACTER) | |
5687 | { | |
5688 | gfc_error ("Expression in CASE selector at %L cannot be %s", | |
5689 | &c->high->where, gfc_typename (&c->high->ts)); | |
5690 | goto cleanup; | |
5691 | } | |
8c6a85e3 TB |
5692 | } |
5693 | else | |
5694 | { | |
5695 | m = gfc_match_init_expr (&c->low); | |
cf2b3c22 TB |
5696 | if (m == MATCH_ERROR) |
5697 | goto cleanup; | |
8c6a85e3 TB |
5698 | if (m == MATCH_NO) |
5699 | goto need_expr; | |
cf2b3c22 | 5700 | |
727cde64 SK |
5701 | if (c->low->ts.type != BT_LOGICAL && c->low->ts.type != BT_INTEGER |
5702 | && c->low->ts.type != BT_CHARACTER) | |
5703 | { | |
5704 | gfc_error ("Expression in CASE selector at %L cannot be %s", | |
5705 | &c->low->where, gfc_typename (&c->low->ts)); | |
5706 | goto cleanup; | |
5707 | } | |
5708 | ||
8c6a85e3 TB |
5709 | /* If we're not looking at a ':' now, make a range out of a single |
5710 | target. Else get the upper bound for the case range. */ | |
5711 | if (gfc_match_char (':') != MATCH_YES) | |
5712 | c->high = c->low; | |
5713 | else | |
5714 | { | |
5715 | m = gfc_match_init_expr (&c->high); | |
5716 | if (m == MATCH_ERROR) | |
5717 | goto cleanup; | |
5718 | /* MATCH_NO is fine. It's OK if nothing is there! */ | |
5719 | } | |
cf2b3c22 TB |
5720 | } |
5721 | ||
8c6a85e3 TB |
5722 | *cp = c; |
5723 | return MATCH_YES; | |
cf2b3c22 | 5724 | |
8c6a85e3 TB |
5725 | need_expr: |
5726 | gfc_error ("Expected initialization expression in CASE at %C"); | |
cf2b3c22 | 5727 | |
8c6a85e3 TB |
5728 | cleanup: |
5729 | free_case (c); | |
5730 | return MATCH_ERROR; | |
5731 | } | |
cf2b3c22 | 5732 | |
cf2b3c22 | 5733 | |
8c6a85e3 | 5734 | /* Match the end of a case statement. */ |
cf2b3c22 | 5735 | |
8c6a85e3 TB |
5736 | static match |
5737 | match_case_eos (void) | |
5738 | { | |
5739 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
5740 | match m; | |
cf2b3c22 | 5741 | |
8c6a85e3 TB |
5742 | if (gfc_match_eos () == MATCH_YES) |
5743 | return MATCH_YES; | |
cf2b3c22 | 5744 | |
8c6a85e3 TB |
5745 | /* If the case construct doesn't have a case-construct-name, we |
5746 | should have matched the EOS. */ | |
5747 | if (!gfc_current_block ()) | |
5748 | return MATCH_NO; | |
cf2b3c22 | 5749 | |
8c6a85e3 | 5750 | gfc_gobble_whitespace (); |
cf2b3c22 | 5751 | |
8c6a85e3 TB |
5752 | m = gfc_match_name (name); |
5753 | if (m != MATCH_YES) | |
5754 | return m; | |
cf2b3c22 | 5755 | |
8c6a85e3 TB |
5756 | if (strcmp (name, gfc_current_block ()->name) != 0) |
5757 | { | |
a4d9b221 | 5758 | gfc_error ("Expected block name %qs of SELECT construct at %C", |
8c6a85e3 TB |
5759 | gfc_current_block ()->name); |
5760 | return MATCH_ERROR; | |
5761 | } | |
cf2b3c22 | 5762 | |
8c6a85e3 TB |
5763 | return gfc_match_eos (); |
5764 | } | |
cf2b3c22 | 5765 | |
6de9cd9a | 5766 | |
8c6a85e3 | 5767 | /* Match a SELECT statement. */ |
c874ae73 | 5768 | |
8c6a85e3 TB |
5769 | match |
5770 | gfc_match_select (void) | |
c874ae73 TS |
5771 | { |
5772 | gfc_expr *expr; | |
c874ae73 TS |
5773 | match m; |
5774 | ||
8c6a85e3 TB |
5775 | m = gfc_match_label (); |
5776 | if (m == MATCH_ERROR) | |
5777 | return m; | |
5778 | ||
5779 | m = gfc_match (" select case ( %e )%t", &expr); | |
c874ae73 TS |
5780 | if (m != MATCH_YES) |
5781 | return m; | |
5782 | ||
8c6a85e3 TB |
5783 | new_st.op = EXEC_SELECT; |
5784 | new_st.expr1 = expr; | |
c874ae73 | 5785 | |
8c6a85e3 TB |
5786 | return MATCH_YES; |
5787 | } | |
c874ae73 | 5788 | |
c874ae73 | 5789 | |
8f75db9f PT |
5790 | /* Transfer the selector typespec to the associate name. */ |
5791 | ||
5792 | static void | |
5793 | copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector) | |
5794 | { | |
5795 | gfc_ref *ref; | |
5796 | gfc_symbol *assoc_sym; | |
5797 | ||
5798 | assoc_sym = associate->symtree->n.sym; | |
5799 | ||
8f75db9f PT |
5800 | /* At this stage the expression rank and arrayspec dimensions have |
5801 | not been completely sorted out. We must get the expr2->rank | |
5802 | right here, so that the correct class container is obtained. */ | |
5803 | ref = selector->ref; | |
5804 | while (ref && ref->next) | |
5805 | ref = ref->next; | |
5806 | ||
a7a6a027 JW |
5807 | if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as |
5808 | && ref && ref->type == REF_ARRAY) | |
8f75db9f | 5809 | { |
e4821cd8 PT |
5810 | /* Ensure that the array reference type is set. We cannot use |
5811 | gfc_resolve_expr at this point, so the usable parts of | |
5812 | resolve.c(resolve_array_ref) are employed to do it. */ | |
5813 | if (ref->u.ar.type == AR_UNKNOWN) | |
5814 | { | |
5815 | ref->u.ar.type = AR_ELEMENT; | |
a7a6a027 | 5816 | for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++) |
e4821cd8 PT |
5817 | if (ref->u.ar.dimen_type[i] == DIMEN_RANGE |
5818 | || ref->u.ar.dimen_type[i] == DIMEN_VECTOR | |
5819 | || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN | |
5820 | && ref->u.ar.start[i] && ref->u.ar.start[i]->rank)) | |
5821 | { | |
5822 | ref->u.ar.type = AR_SECTION; | |
5823 | break; | |
5824 | } | |
5825 | } | |
5826 | ||
8f75db9f PT |
5827 | if (ref->u.ar.type == AR_FULL) |
5828 | selector->rank = CLASS_DATA (selector)->as->rank; | |
5829 | else if (ref->u.ar.type == AR_SECTION) | |
5830 | selector->rank = ref->u.ar.dimen; | |
5831 | else | |
5832 | selector->rank = 0; | |
5833 | } | |
5834 | ||
a7a6a027 | 5835 | if (selector->rank) |
8f75db9f | 5836 | { |
a7a6a027 JW |
5837 | assoc_sym->attr.dimension = 1; |
5838 | assoc_sym->as = gfc_get_array_spec (); | |
5839 | assoc_sym->as->rank = selector->rank; | |
5840 | assoc_sym->as->type = AS_DEFERRED; | |
8f75db9f PT |
5841 | } |
5842 | else | |
a7a6a027 JW |
5843 | assoc_sym->as = NULL; |
5844 | ||
5845 | if (selector->ts.type == BT_CLASS) | |
8f75db9f PT |
5846 | { |
5847 | /* The correct class container has to be available. */ | |
8f75db9f PT |
5848 | assoc_sym->ts.type = BT_CLASS; |
5849 | assoc_sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived; | |
5850 | assoc_sym->attr.pointer = 1; | |
9b6da3c7 | 5851 | gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as); |
8f75db9f PT |
5852 | } |
5853 | } | |
5854 | ||
5855 | ||
8c6a85e3 | 5856 | /* Push the current selector onto the SELECT TYPE stack. */ |
c874ae73 | 5857 | |
8c6a85e3 TB |
5858 | static void |
5859 | select_type_push (gfc_symbol *sel) | |
5860 | { | |
5861 | gfc_select_type_stack *top = gfc_get_select_type_stack (); | |
5862 | top->selector = sel; | |
5863 | top->tmp = NULL; | |
5864 | top->prev = select_type_stack; | |
c874ae73 | 5865 | |
8c6a85e3 TB |
5866 | select_type_stack = top; |
5867 | } | |
c874ae73 | 5868 | |
c874ae73 | 5869 | |
8b704316 PT |
5870 | /* Set the temporary for the current intrinsic SELECT TYPE selector. */ |
5871 | ||
5872 | static gfc_symtree * | |
5873 | select_intrinsic_set_tmp (gfc_typespec *ts) | |
5874 | { | |
5875 | char name[GFC_MAX_SYMBOL_LEN]; | |
5876 | gfc_symtree *tmp; | |
c1e9bbcc | 5877 | int charlen = 0; |
8b704316 PT |
5878 | |
5879 | if (ts->type == BT_CLASS || ts->type == BT_DERIVED) | |
5880 | return NULL; | |
5881 | ||
5882 | if (select_type_stack->selector->ts.type == BT_CLASS | |
5883 | && !select_type_stack->selector->attr.class_ok) | |
5884 | return NULL; | |
5885 | ||
5886 | if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length | |
5887 | && ts->u.cl->length->expr_type == EXPR_CONSTANT) | |
c1e9bbcc | 5888 | charlen = mpz_get_si (ts->u.cl->length->value.integer); |
8b704316 PT |
5889 | |
5890 | if (ts->type != BT_CHARACTER) | |
5891 | sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type), | |
5892 | ts->kind); | |
5893 | else | |
c1e9bbcc JB |
5894 | sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (ts->type), |
5895 | charlen, ts->kind); | |
8b704316 PT |
5896 | |
5897 | gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); | |
5898 | gfc_add_type (tmp->n.sym, ts, NULL); | |
5899 | ||
5900 | /* Copy across the array spec to the selector. */ | |
5901 | if (select_type_stack->selector->ts.type == BT_CLASS | |
5902 | && (CLASS_DATA (select_type_stack->selector)->attr.dimension | |
5903 | || CLASS_DATA (select_type_stack->selector)->attr.codimension)) | |
5904 | { | |
5905 | tmp->n.sym->attr.pointer = 1; | |
5906 | tmp->n.sym->attr.dimension | |
5907 | = CLASS_DATA (select_type_stack->selector)->attr.dimension; | |
5908 | tmp->n.sym->attr.codimension | |
5909 | = CLASS_DATA (select_type_stack->selector)->attr.codimension; | |
5910 | tmp->n.sym->as | |
5911 | = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as); | |
5912 | } | |
5913 | ||
5914 | gfc_set_sym_referenced (tmp->n.sym); | |
5915 | gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); | |
5916 | tmp->n.sym->attr.select_type_temporary = 1; | |
5917 | ||
5918 | return tmp; | |
5919 | } | |
5920 | ||
5921 | ||
fca04db3 | 5922 | /* Set up a temporary for the current TYPE IS / CLASS IS branch . */ |
c874ae73 | 5923 | |
fca04db3 JW |
5924 | static void |
5925 | select_type_set_tmp (gfc_typespec *ts) | |
8c6a85e3 TB |
5926 | { |
5927 | char name[GFC_MAX_SYMBOL_LEN]; | |
8b704316 | 5928 | gfc_symtree *tmp = NULL; |
8f75db9f | 5929 | |
fca04db3 | 5930 | if (!ts) |
8c6a85e3 | 5931 | { |
fca04db3 JW |
5932 | select_type_stack->tmp = NULL; |
5933 | return; | |
8c6a85e3 | 5934 | } |
8c6a85e3 | 5935 | |
8b704316 | 5936 | tmp = select_intrinsic_set_tmp (ts); |
c49ea23d | 5937 | |
8b704316 | 5938 | if (tmp == NULL) |
c49ea23d | 5939 | { |
4cc70466 PT |
5940 | if (!ts->u.derived) |
5941 | return; | |
5942 | ||
8b704316 PT |
5943 | if (ts->type == BT_CLASS) |
5944 | sprintf (name, "__tmp_class_%s", ts->u.derived->name); | |
5945 | else | |
5946 | sprintf (name, "__tmp_type_%s", ts->u.derived->name); | |
5947 | gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); | |
5948 | gfc_add_type (tmp->n.sym, ts, NULL); | |
fca04db3 | 5949 | |
8b704316 PT |
5950 | if (select_type_stack->selector->ts.type == BT_CLASS |
5951 | && select_type_stack->selector->attr.class_ok) | |
fca04db3 | 5952 | { |
8b704316 PT |
5953 | tmp->n.sym->attr.pointer |
5954 | = CLASS_DATA (select_type_stack->selector)->attr.class_pointer; | |
5955 | ||
5956 | /* Copy across the array spec to the selector. */ | |
5957 | if (CLASS_DATA (select_type_stack->selector)->attr.dimension | |
5958 | || CLASS_DATA (select_type_stack->selector)->attr.codimension) | |
5959 | { | |
5960 | tmp->n.sym->attr.dimension | |
fca04db3 | 5961 | = CLASS_DATA (select_type_stack->selector)->attr.dimension; |
8b704316 | 5962 | tmp->n.sym->attr.codimension |
fca04db3 | 5963 | = CLASS_DATA (select_type_stack->selector)->attr.codimension; |
8b704316 | 5964 | tmp->n.sym->as |
fca04db3 | 5965 | = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as); |
8b704316 | 5966 | } |
c49ea23d PT |
5967 | } |
5968 | ||
8c6a85e3 | 5969 | gfc_set_sym_referenced (tmp->n.sym); |
8c6a85e3 | 5970 | gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); |
7d40e49f | 5971 | tmp->n.sym->attr.select_type_temporary = 1; |
8f75db9f | 5972 | |
8c6a85e3 | 5973 | if (ts->type == BT_CLASS) |
fca04db3 | 5974 | gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr, |
9b6da3c7 | 5975 | &tmp->n.sym->as); |
8b704316 | 5976 | } |
8c6a85e3 TB |
5977 | |
5978 | /* Add an association for it, so the rest of the parser knows it is | |
5979 | an associate-name. The target will be set during resolution. */ | |
5980 | tmp->n.sym->assoc = gfc_get_association_list (); | |
5981 | tmp->n.sym->assoc->dangling = 1; | |
5982 | tmp->n.sym->assoc->st = tmp; | |
5983 | ||
5984 | select_type_stack->tmp = tmp; | |
c874ae73 TS |
5985 | } |
5986 | ||
8b704316 | 5987 | |
8c6a85e3 | 5988 | /* Match a SELECT TYPE statement. */ |
6de9cd9a DN |
5989 | |
5990 | match | |
8c6a85e3 | 5991 | gfc_match_select_type (void) |
6de9cd9a | 5992 | { |
8c6a85e3 TB |
5993 | gfc_expr *expr1, *expr2 = NULL; |
5994 | match m; | |
5995 | char name[GFC_MAX_SYMBOL_LEN]; | |
c49ea23d | 5996 | bool class_array; |
8f75db9f | 5997 | gfc_symbol *sym; |
6f21288f | 5998 | gfc_namespace *ns = gfc_current_ns; |
6de9cd9a | 5999 | |
8c6a85e3 TB |
6000 | m = gfc_match_label (); |
6001 | if (m == MATCH_ERROR) | |
6002 | return m; | |
6de9cd9a | 6003 | |
8c6a85e3 | 6004 | m = gfc_match (" select type ( "); |
6de9cd9a DN |
6005 | if (m != MATCH_YES) |
6006 | return m; | |
6007 | ||
6f21288f | 6008 | gfc_current_ns = gfc_build_block_ns (ns); |
8c6a85e3 TB |
6009 | m = gfc_match (" %n => %e", name, &expr2); |
6010 | if (m == MATCH_YES) | |
6011 | { | |
6f21288f | 6012 | expr1 = gfc_get_expr (); |
8c6a85e3 | 6013 | expr1->expr_type = EXPR_VARIABLE; |
ce386153 | 6014 | expr1->where = expr2->where; |
8c6a85e3 TB |
6015 | if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) |
6016 | { | |
6017 | m = MATCH_ERROR; | |
6018 | goto cleanup; | |
6019 | } | |
8f75db9f PT |
6020 | |
6021 | sym = expr1->symtree->n.sym; | |
8c6a85e3 | 6022 | if (expr2->ts.type == BT_UNKNOWN) |
8f75db9f | 6023 | sym->attr.untyped = 1; |
8c6a85e3 | 6024 | else |
8f75db9f PT |
6025 | copy_ts_from_selector_to_associate (expr1, expr2); |
6026 | ||
6027 | sym->attr.flavor = FL_VARIABLE; | |
6028 | sym->attr.referenced = 1; | |
6029 | sym->attr.class_ok = 1; | |
8c6a85e3 TB |
6030 | } |
6031 | else | |
6de9cd9a | 6032 | { |
8c6a85e3 TB |
6033 | m = gfc_match (" %e ", &expr1); |
6034 | if (m != MATCH_YES) | |
6f21288f JJ |
6035 | { |
6036 | std::swap (ns, gfc_current_ns); | |
6037 | gfc_free_namespace (ns); | |
6038 | return m; | |
6039 | } | |
6de9cd9a DN |
6040 | } |
6041 | ||
8c6a85e3 | 6042 | m = gfc_match (" )%t"); |
6de9cd9a | 6043 | if (m != MATCH_YES) |
a5e52264 MM |
6044 | { |
6045 | gfc_error ("parse error in SELECT TYPE statement at %C"); | |
6046 | goto cleanup; | |
6047 | } | |
8c6a85e3 | 6048 | |
c49ea23d PT |
6049 | /* This ghastly expression seems to be needed to distinguish a CLASS |
6050 | array, which can have a reference, from other expressions that | |
6051 | have references, such as derived type components, and are not | |
6052 | allowed by the standard. | |
ee3bea0b | 6053 | TODO: see if it is sufficient to exclude component and substring |
c49ea23d | 6054 | references. */ |
6f21288f JJ |
6055 | class_array = (expr1->expr_type == EXPR_VARIABLE |
6056 | && expr1->ts.type == BT_CLASS | |
6057 | && CLASS_DATA (expr1) | |
6058 | && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0) | |
6059 | && (CLASS_DATA (expr1)->attr.dimension | |
6060 | || CLASS_DATA (expr1)->attr.codimension) | |
6061 | && expr1->ref | |
6062 | && expr1->ref->type == REF_ARRAY | |
6063 | && expr1->ref->next == NULL); | |
c49ea23d | 6064 | |
8c6a85e3 | 6065 | /* Check for F03:C811. */ |
c49ea23d | 6066 | if (!expr2 && (expr1->expr_type != EXPR_VARIABLE |
6f21288f | 6067 | || (!class_array && expr1->ref != NULL))) |
6de9cd9a | 6068 | { |
8c6a85e3 TB |
6069 | gfc_error ("Selector in SELECT TYPE at %C is not a named variable; " |
6070 | "use associate-name=>"); | |
6071 | m = MATCH_ERROR; | |
6072 | goto cleanup; | |
6de9cd9a DN |
6073 | } |
6074 | ||
8c6a85e3 TB |
6075 | new_st.op = EXEC_SELECT_TYPE; |
6076 | new_st.expr1 = expr1; | |
6077 | new_st.expr2 = expr2; | |
6078 | new_st.ext.block.ns = gfc_current_ns; | |
6de9cd9a | 6079 | |
8c6a85e3 | 6080 | select_type_push (expr1->symtree->n.sym); |
6f21288f | 6081 | gfc_current_ns = ns; |
6de9cd9a DN |
6082 | |
6083 | return MATCH_YES; | |
8b704316 | 6084 | |
8c6a85e3 | 6085 | cleanup: |
36abe895 TB |
6086 | gfc_free_expr (expr1); |
6087 | gfc_free_expr (expr2); | |
6f21288f JJ |
6088 | gfc_undo_symbols (); |
6089 | std::swap (ns, gfc_current_ns); | |
6090 | gfc_free_namespace (ns); | |
8c6a85e3 | 6091 | return m; |
6de9cd9a DN |
6092 | } |
6093 | ||
6094 | ||
8c6a85e3 | 6095 | /* Match a CASE statement. */ |
6de9cd9a DN |
6096 | |
6097 | match | |
8c6a85e3 | 6098 | gfc_match_case (void) |
6de9cd9a | 6099 | { |
8c6a85e3 | 6100 | gfc_case *c, *head, *tail; |
6de9cd9a DN |
6101 | match m; |
6102 | ||
8c6a85e3 TB |
6103 | head = tail = NULL; |
6104 | ||
6105 | if (gfc_current_state () != COMP_SELECT) | |
6de9cd9a | 6106 | { |
8c6a85e3 | 6107 | gfc_error ("Unexpected CASE statement at %C"); |
6de9cd9a DN |
6108 | return MATCH_ERROR; |
6109 | } | |
6110 | ||
8c6a85e3 | 6111 | if (gfc_match ("% default") == MATCH_YES) |
6de9cd9a | 6112 | { |
8c6a85e3 | 6113 | m = match_case_eos (); |
6de9cd9a DN |
6114 | if (m == MATCH_NO) |
6115 | goto syntax; | |
6116 | if (m == MATCH_ERROR) | |
8c6a85e3 | 6117 | goto cleanup; |
6de9cd9a | 6118 | |
8c6a85e3 TB |
6119 | new_st.op = EXEC_SELECT; |
6120 | c = gfc_get_case (); | |
6121 | c->where = gfc_current_locus; | |
6122 | new_st.ext.block.case_list = c; | |
6123 | return MATCH_YES; | |
6de9cd9a DN |
6124 | } |
6125 | ||
8c6a85e3 TB |
6126 | if (gfc_match_char ('(') != MATCH_YES) |
6127 | goto syntax; | |
6128 | ||
6129 | for (;;) | |
690af379 | 6130 | { |
8c6a85e3 | 6131 | if (match_case_selector (&c) == MATCH_ERROR) |
6de9cd9a DN |
6132 | goto cleanup; |
6133 | ||
8c6a85e3 TB |
6134 | if (head == NULL) |
6135 | head = c; | |
6136 | else | |
6137 | tail->next = c; | |
6de9cd9a | 6138 | |
8c6a85e3 TB |
6139 | tail = c; |
6140 | ||
6141 | if (gfc_match_char (')') == MATCH_YES) | |
6142 | break; | |
6143 | if (gfc_match_char (',') != MATCH_YES) | |
6144 | goto syntax; | |
6de9cd9a DN |
6145 | } |
6146 | ||
8c6a85e3 TB |
6147 | m = match_case_eos (); |
6148 | if (m == MATCH_NO) | |
6149 | goto syntax; | |
6150 | if (m == MATCH_ERROR) | |
6151 | goto cleanup; | |
6152 | ||
6153 | new_st.op = EXEC_SELECT; | |
6154 | new_st.ext.block.case_list = head; | |
6155 | ||
6de9cd9a DN |
6156 | return MATCH_YES; |
6157 | ||
6158 | syntax: | |
8c6a85e3 | 6159 | gfc_error ("Syntax error in CASE specification at %C"); |
6de9cd9a DN |
6160 | |
6161 | cleanup: | |
8c6a85e3 | 6162 | gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */ |
6de9cd9a DN |
6163 | return MATCH_ERROR; |
6164 | } | |
6165 | ||
6166 | ||
8c6a85e3 | 6167 | /* Match a TYPE IS statement. */ |
6de9cd9a | 6168 | |
8c6a85e3 TB |
6169 | match |
6170 | gfc_match_type_is (void) | |
6de9cd9a | 6171 | { |
8c6a85e3 TB |
6172 | gfc_case *c = NULL; |
6173 | match m; | |
6de9cd9a | 6174 | |
8c6a85e3 | 6175 | if (gfc_current_state () != COMP_SELECT_TYPE) |
6de9cd9a | 6176 | { |
8c6a85e3 TB |
6177 | gfc_error ("Unexpected TYPE IS statement at %C"); |
6178 | return MATCH_ERROR; | |
6de9cd9a | 6179 | } |
6de9cd9a | 6180 | |
8c6a85e3 TB |
6181 | if (gfc_match_char ('(') != MATCH_YES) |
6182 | goto syntax; | |
6de9cd9a | 6183 | |
8c6a85e3 TB |
6184 | c = gfc_get_case (); |
6185 | c->where = gfc_current_locus; | |
6de9cd9a | 6186 | |
ef701bbe SK |
6187 | m = gfc_match_type_spec (&c->ts); |
6188 | if (m == MATCH_NO) | |
6189 | goto syntax; | |
6190 | if (m == MATCH_ERROR) | |
6de9cd9a DN |
6191 | goto cleanup; |
6192 | ||
8c6a85e3 | 6193 | if (gfc_match_char (')') != MATCH_YES) |
6de9cd9a DN |
6194 | goto syntax; |
6195 | ||
8c6a85e3 | 6196 | m = match_case_eos (); |
6de9cd9a DN |
6197 | if (m == MATCH_NO) |
6198 | goto syntax; | |
6199 | if (m == MATCH_ERROR) | |
6200 | goto cleanup; | |
6201 | ||
8c6a85e3 TB |
6202 | new_st.op = EXEC_SELECT_TYPE; |
6203 | new_st.ext.block.case_list = c; | |
6de9cd9a | 6204 | |
8b704316 PT |
6205 | if (c->ts.type == BT_DERIVED && c->ts.u.derived |
6206 | && (c->ts.u.derived->attr.sequence | |
6207 | || c->ts.u.derived->attr.is_bind_c)) | |
6208 | { | |
6209 | gfc_error ("The type-spec shall not specify a sequence derived " | |
6210 | "type or a type with the BIND attribute in SELECT " | |
6211 | "TYPE at %C [F2003:C815]"); | |
6212 | return MATCH_ERROR; | |
6213 | } | |
6214 | ||
5bab4c96 PT |
6215 | if (c->ts.type == BT_DERIVED |
6216 | && c->ts.u.derived && c->ts.u.derived->attr.pdt_type | |
6217 | && gfc_spec_list_type (type_param_spec_list, c->ts.u.derived) | |
6218 | != SPEC_ASSUMED) | |
6219 | { | |
6220 | gfc_error ("All the LEN type parameters in the TYPE IS statement " | |
6221 | "at %C must be ASSUMED"); | |
6222 | return MATCH_ERROR; | |
6223 | } | |
6224 | ||
8c6a85e3 TB |
6225 | /* Create temporary variable. */ |
6226 | select_type_set_tmp (&c->ts); | |
31708dc6 | 6227 | |
6de9cd9a DN |
6228 | return MATCH_YES; |
6229 | ||
6230 | syntax: | |
d185db14 | 6231 | gfc_error ("Syntax error in TYPE IS specification at %C"); |
6de9cd9a DN |
6232 | |
6233 | cleanup: | |
8c6a85e3 TB |
6234 | if (c != NULL) |
6235 | gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ | |
6236 | return MATCH_ERROR; | |
6237 | } | |
d68bd5a8 | 6238 | |
c874ae73 | 6239 | |
8c6a85e3 TB |
6240 | /* Match a CLASS IS or CLASS DEFAULT statement. */ |
6241 | ||
6242 | match | |
6243 | gfc_match_class_is (void) | |
6244 | { | |
6245 | gfc_case *c = NULL; | |
6246 | match m; | |
6247 | ||
6248 | if (gfc_current_state () != COMP_SELECT_TYPE) | |
6249 | return MATCH_NO; | |
6250 | ||
6251 | if (gfc_match ("% default") == MATCH_YES) | |
6252 | { | |
6253 | m = match_case_eos (); | |
6de9cd9a DN |
6254 | if (m == MATCH_NO) |
6255 | goto syntax; | |
6256 | if (m == MATCH_ERROR) | |
6257 | goto cleanup; | |
6258 | ||
8c6a85e3 TB |
6259 | new_st.op = EXEC_SELECT_TYPE; |
6260 | c = gfc_get_case (); | |
6261 | c->where = gfc_current_locus; | |
6262 | c->ts.type = BT_UNKNOWN; | |
6263 | new_st.ext.block.case_list = c; | |
6264 | select_type_set_tmp (NULL); | |
6265 | return MATCH_YES; | |
6de9cd9a DN |
6266 | } |
6267 | ||
8c6a85e3 TB |
6268 | m = gfc_match ("% is"); |
6269 | if (m == MATCH_NO) | |
6de9cd9a | 6270 | goto syntax; |
8c6a85e3 TB |
6271 | if (m == MATCH_ERROR) |
6272 | goto cleanup; | |
6273 | ||
6274 | if (gfc_match_char ('(') != MATCH_YES) | |
6275 | goto syntax; | |
6276 | ||
6277 | c = gfc_get_case (); | |
6278 | c->where = gfc_current_locus; | |
6279 | ||
ef701bbe SK |
6280 | m = match_derived_type_spec (&c->ts); |
6281 | if (m == MATCH_NO) | |
6282 | goto syntax; | |
6283 | if (m == MATCH_ERROR) | |
8c6a85e3 TB |
6284 | goto cleanup; |
6285 | ||
6286 | if (c->ts.type == BT_DERIVED) | |
6287 | c->ts.type = BT_CLASS; | |
6288 | ||
6289 | if (gfc_match_char (')') != MATCH_YES) | |
6290 | goto syntax; | |
6291 | ||
6292 | m = match_case_eos (); | |
6293 | if (m == MATCH_NO) | |
6294 | goto syntax; | |
6295 | if (m == MATCH_ERROR) | |
6296 | goto cleanup; | |
6297 | ||
6298 | new_st.op = EXEC_SELECT_TYPE; | |
6299 | new_st.ext.block.case_list = c; | |
8b704316 | 6300 | |
8c6a85e3 TB |
6301 | /* Create temporary variable. */ |
6302 | select_type_set_tmp (&c->ts); | |
6de9cd9a | 6303 | |
c874ae73 TS |
6304 | return MATCH_YES; |
6305 | ||
6306 | syntax: | |
8c6a85e3 | 6307 | gfc_error ("Syntax error in CLASS IS specification at %C"); |
c874ae73 TS |
6308 | |
6309 | cleanup: | |
8c6a85e3 TB |
6310 | if (c != NULL) |
6311 | gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ | |
c874ae73 TS |
6312 | return MATCH_ERROR; |
6313 | } | |
6314 | ||
8c6a85e3 TB |
6315 | |
6316 | /********************* WHERE subroutines ********************/ | |
6317 | ||
8b704316 | 6318 | /* Match the rest of a simple WHERE statement that follows an IF statement. |
8c6a85e3 | 6319 | */ |
c874ae73 TS |
6320 | |
6321 | static match | |
8c6a85e3 | 6322 | match_simple_where (void) |
c874ae73 | 6323 | { |
8c6a85e3 | 6324 | gfc_expr *expr; |
c874ae73 TS |
6325 | gfc_code *c; |
6326 | match m; | |
6327 | ||
8c6a85e3 | 6328 | m = gfc_match (" ( %e )", &expr); |
c874ae73 | 6329 | if (m != MATCH_YES) |
8c6a85e3 | 6330 | return m; |
c874ae73 TS |
6331 | |
6332 | m = gfc_match_assignment (); | |
8c6a85e3 TB |
6333 | if (m == MATCH_NO) |
6334 | goto syntax; | |
c874ae73 TS |
6335 | if (m == MATCH_ERROR) |
6336 | goto cleanup; | |
c874ae73 TS |
6337 | |
6338 | if (gfc_match_eos () != MATCH_YES) | |
6339 | goto syntax; | |
6340 | ||
11e5274a | 6341 | c = gfc_get_code (EXEC_WHERE); |
8c6a85e3 | 6342 | c->expr1 = expr; |
8c6a85e3 | 6343 | |
11e5274a | 6344 | c->next = XCNEW (gfc_code); |
8c6a85e3 | 6345 | *c->next = new_st; |
5b7c0519 | 6346 | c->next->loc = gfc_current_locus; |
c874ae73 | 6347 | gfc_clear_new_st (); |
c874ae73 | 6348 | |
8c6a85e3 TB |
6349 | new_st.op = EXEC_WHERE; |
6350 | new_st.block = c; | |
c874ae73 TS |
6351 | |
6352 | return MATCH_YES; | |
6353 | ||
6354 | syntax: | |
8c6a85e3 | 6355 | gfc_syntax_error (ST_WHERE); |
c874ae73 TS |
6356 | |
6357 | cleanup: | |
8c6a85e3 | 6358 | gfc_free_expr (expr); |
c874ae73 TS |
6359 | return MATCH_ERROR; |
6360 | } | |
6361 | ||
6362 | ||
8c6a85e3 | 6363 | /* Match a WHERE statement. */ |
c874ae73 TS |
6364 | |
6365 | match | |
8c6a85e3 | 6366 | gfc_match_where (gfc_statement *st) |
c874ae73 | 6367 | { |
8c6a85e3 | 6368 | gfc_expr *expr; |
c874ae73 | 6369 | match m0, m; |
8c6a85e3 | 6370 | gfc_code *c; |
c874ae73 TS |
6371 | |
6372 | m0 = gfc_match_label (); | |
6373 | if (m0 == MATCH_ERROR) | |
8c6a85e3 | 6374 | return m0; |
c874ae73 | 6375 | |
8c6a85e3 | 6376 | m = gfc_match (" where ( %e )", &expr); |
c874ae73 TS |
6377 | if (m != MATCH_YES) |
6378 | return m; | |
6379 | ||
6de9cd9a DN |
6380 | if (gfc_match_eos () == MATCH_YES) |
6381 | { | |
8c6a85e3 TB |
6382 | *st = ST_WHERE_BLOCK; |
6383 | new_st.op = EXEC_WHERE; | |
6384 | new_st.expr1 = expr; | |
6de9cd9a DN |
6385 | return MATCH_YES; |
6386 | } | |
6387 | ||
6388 | m = gfc_match_assignment (); | |
6de9cd9a | 6389 | if (m == MATCH_NO) |
8c6a85e3 TB |
6390 | gfc_syntax_error (ST_WHERE); |
6391 | ||
6392 | if (m != MATCH_YES) | |
6de9cd9a | 6393 | { |
8c6a85e3 TB |
6394 | gfc_free_expr (expr); |
6395 | return MATCH_ERROR; | |
6de9cd9a DN |
6396 | } |
6397 | ||
8c6a85e3 TB |
6398 | /* We've got a simple WHERE statement. */ |
6399 | *st = ST_WHERE; | |
11e5274a | 6400 | c = gfc_get_code (EXEC_WHERE); |
8c6a85e3 | 6401 | c->expr1 = expr; |
8c6a85e3 | 6402 | |
7f4266d4 TK |
6403 | /* Put in the assignment. It will not be processed by add_statement, so we |
6404 | need to copy the location here. */ | |
6405 | ||
11e5274a | 6406 | c->next = XCNEW (gfc_code); |
8c6a85e3 | 6407 | *c->next = new_st; |
7f4266d4 | 6408 | c->next->loc = gfc_current_locus; |
6de9cd9a | 6409 | gfc_clear_new_st (); |
6de9cd9a | 6410 | |
8c6a85e3 TB |
6411 | new_st.op = EXEC_WHERE; |
6412 | new_st.block = c; | |
6413 | ||
6414 | return MATCH_YES; | |
6415 | } | |
6416 | ||
6417 | ||
6418 | /* Match an ELSEWHERE statement. We leave behind a WHERE node in | |
6419 | new_st if successful. */ | |
6420 | ||
6421 | match | |
6422 | gfc_match_elsewhere (void) | |
6423 | { | |
6424 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
6425 | gfc_expr *expr; | |
6426 | match m; | |
6427 | ||
6428 | if (gfc_current_state () != COMP_WHERE) | |
6429 | { | |
6430 | gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block"); | |
6431 | return MATCH_ERROR; | |
6432 | } | |
6433 | ||
6434 | expr = NULL; | |
6435 | ||
6436 | if (gfc_match_char ('(') == MATCH_YES) | |
6437 | { | |
6438 | m = gfc_match_expr (&expr); | |
6439 | if (m == MATCH_NO) | |
6440 | goto syntax; | |
6441 | if (m == MATCH_ERROR) | |
6442 | return MATCH_ERROR; | |
6443 | ||
6444 | if (gfc_match_char (')') != MATCH_YES) | |
6445 | goto syntax; | |
6446 | } | |
6447 | ||
6448 | if (gfc_match_eos () != MATCH_YES) | |
6449 | { | |
6450 | /* Only makes sense if we have a where-construct-name. */ | |
6451 | if (!gfc_current_block ()) | |
6452 | { | |
6453 | m = MATCH_ERROR; | |
6454 | goto cleanup; | |
6455 | } | |
6456 | /* Better be a name at this point. */ | |
6457 | m = gfc_match_name (name); | |
6458 | if (m == MATCH_NO) | |
6459 | goto syntax; | |
6460 | if (m == MATCH_ERROR) | |
6461 | goto cleanup; | |
6462 | ||
6463 | if (gfc_match_eos () != MATCH_YES) | |
6464 | goto syntax; | |
6465 | ||
6466 | if (strcmp (name, gfc_current_block ()->name) != 0) | |
6467 | { | |
a4d9b221 | 6468 | gfc_error ("Label %qs at %C doesn't match WHERE label %qs", |
8c6a85e3 TB |
6469 | name, gfc_current_block ()->name); |
6470 | goto cleanup; | |
6471 | } | |
6472 | } | |
6473 | ||
6474 | new_st.op = EXEC_WHERE; | |
6475 | new_st.expr1 = expr; | |
6de9cd9a DN |
6476 | return MATCH_YES; |
6477 | ||
6478 | syntax: | |
8c6a85e3 | 6479 | gfc_syntax_error (ST_ELSEWHERE); |
6de9cd9a DN |
6480 | |
6481 | cleanup: | |
8c6a85e3 TB |
6482 | gfc_free_expr (expr); |
6483 | return MATCH_ERROR; | |
6de9cd9a | 6484 | } |