Branch data Line data Source code
1 : : /* Main parser.
2 : : Copyright (C) 2000-2025 Free Software Foundation, Inc.
3 : : Contributed by Andy Vaught
4 : :
5 : : This file is part of GCC.
6 : :
7 : : GCC is free software; you can redistribute it and/or modify it under
8 : : the terms of the GNU General Public License as published by the Free
9 : : Software Foundation; either version 3, or (at your option) any later
10 : : version.
11 : :
12 : : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : : for more details.
16 : :
17 : : You should have received a copy of the GNU General Public License
18 : : along with GCC; see the file COPYING3. If not see
19 : : <http://www.gnu.org/licenses/>. */
20 : :
21 : : #include "config.h"
22 : : #include "system.h"
23 : : #include "coretypes.h"
24 : : #include "options.h"
25 : : #include "gfortran.h"
26 : : #include <setjmp.h>
27 : : #include "match.h"
28 : : #include "parse.h"
29 : : #include "tree-core.h"
30 : : #include "omp-general.h"
31 : :
32 : : /* Current statement label. Zero means no statement label. Because new_st
33 : : can get wiped during statement matching, we have to keep it separate. */
34 : :
35 : : gfc_st_label *gfc_statement_label;
36 : :
37 : : static locus label_locus;
38 : : static jmp_buf eof_buf;
39 : :
40 : : /* Respectively pointer and content of the current interface body being parsed
41 : : as they were at the beginning of decode_statement. Used to restore the
42 : : interface to its previous state in case a parsed statement is rejected after
43 : : some symbols have been added to the interface. */
44 : : static gfc_interface **current_interface_ptr = nullptr;
45 : : static gfc_interface *previous_interface_head = nullptr;
46 : :
47 : : gfc_state_data *gfc_state_stack;
48 : : static bool last_was_use_stmt = false;
49 : : bool in_exec_part;
50 : :
51 : : /* TODO: Re-order functions to kill these forward decls. */
52 : : static void check_statement_label (gfc_statement);
53 : : static void undo_new_statement (void);
54 : : static void reject_statement (void);
55 : :
56 : :
57 : : /* A sort of half-matching function. We try to match the word on the
58 : : input with the passed string. If this succeeds, we call the
59 : : keyword-dependent matching function that will match the rest of the
60 : : statement. For single keywords, the matching subroutine is
61 : : gfc_match_eos(). */
62 : :
63 : : static match
64 : 22113384 : match_word (const char *str, match (*subr) (void), locus *old_locus)
65 : : {
66 : 22113384 : match m;
67 : :
68 : 22113384 : if (str != NULL)
69 : : {
70 : 13754030 : m = gfc_match (str);
71 : 13754030 : if (m != MATCH_YES)
72 : : return m;
73 : : }
74 : :
75 : 12044522 : m = (*subr) ();
76 : :
77 : 12044519 : if (m != MATCH_YES)
78 : : {
79 : 7962091 : gfc_current_locus = *old_locus;
80 : 7962091 : reject_statement ();
81 : : }
82 : :
83 : : return m;
84 : : }
85 : :
86 : :
87 : : /* Like match_word, but if str is matched, set a flag that it
88 : : was matched. */
89 : : static match
90 : 157703 : match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus,
91 : : bool *simd_matched)
92 : : {
93 : 157703 : match m;
94 : :
95 : 157703 : if (str != NULL)
96 : : {
97 : 157703 : m = gfc_match (str);
98 : 157703 : if (m != MATCH_YES)
99 : : return m;
100 : 3862 : *simd_matched = true;
101 : : }
102 : :
103 : 3862 : m = (*subr) ();
104 : :
105 : 3862 : if (m != MATCH_YES)
106 : : {
107 : 61 : gfc_current_locus = *old_locus;
108 : 61 : reject_statement ();
109 : : }
110 : :
111 : : return m;
112 : : }
113 : :
114 : :
115 : : /* Load symbols from all USE statements encountered in this scoping unit. */
116 : :
117 : : static void
118 : 18881 : use_modules (void)
119 : : {
120 : 18881 : gfc_error_buffer old_error;
121 : :
122 : 18881 : gfc_push_error (&old_error);
123 : 18881 : gfc_buffer_error (false);
124 : 18881 : gfc_use_modules ();
125 : 18878 : gfc_buffer_error (true);
126 : 18878 : gfc_pop_error (&old_error);
127 : 18878 : gfc_commit_symbols ();
128 : 18878 : gfc_warning_check ();
129 : 18878 : gfc_current_ns->old_equiv = gfc_current_ns->equiv;
130 : 18878 : gfc_current_ns->old_data = gfc_current_ns->data;
131 : 18878 : last_was_use_stmt = false;
132 : 18878 : }
133 : :
134 : :
135 : : /* Figure out what the next statement is, (mostly) regardless of
136 : : proper ordering. The do...while(0) is there to prevent if/else
137 : : ambiguity. */
138 : :
139 : : #define match(keyword, subr, st) \
140 : : do { \
141 : : if (match_word (keyword, subr, &old_locus) == MATCH_YES) \
142 : : return st; \
143 : : else \
144 : : undo_new_statement (); \
145 : : } while (0)
146 : :
147 : :
148 : : /* This is a specialist version of decode_statement that is used
149 : : for the specification statements in a function, whose
150 : : characteristics are deferred into the specification statements.
151 : : eg.: INTEGER (king = mykind) foo ()
152 : : USE mymodule, ONLY mykind.....
153 : : The KIND parameter needs a return after USE or IMPORT, whereas
154 : : derived type declarations can occur anywhere, up the executable
155 : : block. ST_GET_FCN_CHARACTERISTICS is returned when we have run
156 : : out of the correct kind of specification statements. */
157 : : static gfc_statement
158 : 10278 : decode_specification_statement (void)
159 : : {
160 : 10278 : gfc_statement st;
161 : 10278 : locus old_locus;
162 : 10278 : char c;
163 : :
164 : 10278 : if (gfc_match_eos () == MATCH_YES)
165 : : return ST_NONE;
166 : :
167 : 10278 : old_locus = gfc_current_locus;
168 : :
169 : 10278 : if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
170 : : {
171 : 1144 : last_was_use_stmt = true;
172 : 1144 : return ST_USE;
173 : : }
174 : : else
175 : : {
176 : 9134 : undo_new_statement ();
177 : 9134 : if (last_was_use_stmt)
178 : 961 : use_modules ();
179 : : }
180 : :
181 : 9134 : match ("import", gfc_match_import, ST_IMPORT);
182 : :
183 : 8748 : if (gfc_current_block ()->result->ts.type != BT_DERIVED)
184 : 5569 : goto end_of_block;
185 : :
186 : 3179 : match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
187 : 3179 : match (NULL, gfc_match_data_decl, ST_DATA_DECL);
188 : 1196 : match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
189 : :
190 : : /* General statement matching: Instead of testing every possible
191 : : statement, we eliminate most possibilities by peeking at the
192 : : first character. */
193 : :
194 : 1196 : c = gfc_peek_ascii_char ();
195 : :
196 : 1196 : switch (c)
197 : : {
198 : 55 : case 'a':
199 : 55 : match ("abstract% interface", gfc_match_abstract_interface,
200 : : ST_INTERFACE);
201 : 55 : match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
202 : 48 : match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
203 : 47 : match ("automatic", gfc_match_automatic, ST_ATTR_DECL);
204 : 47 : break;
205 : :
206 : 14 : case 'b':
207 : 14 : match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
208 : 14 : break;
209 : :
210 : 117 : case 'c':
211 : 117 : match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
212 : 116 : match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
213 : 44 : break;
214 : :
215 : 5 : case 'd':
216 : 5 : match ("data", gfc_match_data, ST_DATA);
217 : 5 : match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
218 : 4 : break;
219 : :
220 : 536 : case 'e':
221 : 536 : match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
222 : 536 : match ("entry% ", gfc_match_entry, ST_ENTRY);
223 : 536 : match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
224 : 536 : match ("external", gfc_match_external, ST_ATTR_DECL);
225 : 536 : break;
226 : :
227 : 45 : case 'f':
228 : 45 : match ("format", gfc_match_format, ST_FORMAT);
229 : 45 : break;
230 : :
231 : : case 'g':
232 : : break;
233 : :
234 : 254 : case 'i':
235 : 254 : match ("implicit", gfc_match_implicit, ST_IMPLICIT);
236 : 254 : match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
237 : 235 : match ("interface", gfc_match_interface, ST_INTERFACE);
238 : 235 : match ("intent", gfc_match_intent, ST_ATTR_DECL);
239 : 127 : match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
240 : 127 : break;
241 : :
242 : : case 'm':
243 : : break;
244 : :
245 : 16 : case 'n':
246 : 16 : match ("namelist", gfc_match_namelist, ST_NAMELIST);
247 : 16 : break;
248 : :
249 : 0 : case 'o':
250 : 0 : match ("optional", gfc_match_optional, ST_ATTR_DECL);
251 : 0 : break;
252 : :
253 : 105 : case 'p':
254 : 105 : match ("parameter", gfc_match_parameter, ST_PARAMETER);
255 : 105 : match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
256 : 105 : if (gfc_match_private (&st) == MATCH_YES)
257 : 0 : return st;
258 : 105 : match ("procedure", gfc_match_procedure, ST_PROCEDURE);
259 : 102 : if (gfc_match_public (&st) == MATCH_YES)
260 : 0 : return st;
261 : 102 : match ("protected", gfc_match_protected, ST_ATTR_DECL);
262 : 102 : break;
263 : :
264 : : case 'r':
265 : : break;
266 : :
267 : 6 : case 's':
268 : 6 : match ("save", gfc_match_save, ST_ATTR_DECL);
269 : 6 : match ("static", gfc_match_static, ST_ATTR_DECL);
270 : 6 : match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL);
271 : 6 : break;
272 : :
273 : 18 : case 't':
274 : 18 : match ("target", gfc_match_target, ST_ATTR_DECL);
275 : 18 : match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
276 : 8 : break;
277 : :
278 : : case 'u':
279 : : break;
280 : :
281 : 1 : case 'v':
282 : 1 : match ("value", gfc_match_value, ST_ATTR_DECL);
283 : 1 : match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
284 : 0 : break;
285 : :
286 : : case 'w':
287 : : break;
288 : : }
289 : :
290 : : /* This is not a specification statement. See if any of the matchers
291 : : has stored an error message of some sort. */
292 : :
293 : 6542 : end_of_block:
294 : 6542 : gfc_clear_error ();
295 : 6542 : gfc_buffer_error (false);
296 : 6542 : gfc_current_locus = old_locus;
297 : :
298 : 6542 : return ST_GET_FCN_CHARACTERISTICS;
299 : : }
300 : :
301 : :
302 : : /* Tells whether gfc_get_current_interface_head can be used safely. */
303 : :
304 : : static bool
305 : 1184260 : current_interface_valid_p ()
306 : : {
307 : 1184260 : switch (current_interface.type)
308 : : {
309 : 9822 : case INTERFACE_INTRINSIC_OP:
310 : 9822 : return current_interface.ns != nullptr;
311 : :
312 : 71718 : case INTERFACE_GENERIC:
313 : 71718 : case INTERFACE_DTIO:
314 : 71718 : return current_interface.sym != nullptr;
315 : :
316 : 2694 : case INTERFACE_USER_OP:
317 : 2694 : return current_interface.uop != nullptr;
318 : :
319 : : default:
320 : : return false;
321 : : }
322 : : }
323 : :
324 : :
325 : : /* Return a pointer to the interface currently being parsed, or nullptr if
326 : : we are not currently parsing an interface body. */
327 : :
328 : : static gfc_interface **
329 : 1184260 : get_current_interface_ptr ()
330 : : {
331 : 1184260 : if (current_interface_valid_p ())
332 : : {
333 : 84233 : gfc_interface *& ifc_ptr = gfc_current_interface_head ();
334 : 84233 : return &ifc_ptr;
335 : : }
336 : : else
337 : : return nullptr;
338 : : }
339 : :
340 : :
341 : : static bool in_specification_block;
342 : :
343 : : /* This is the primary 'decode_statement'. */
344 : : static gfc_statement
345 : 1184260 : decode_statement (void)
346 : : {
347 : 1184260 : gfc_statement st;
348 : 1184260 : locus old_locus;
349 : 1184260 : match m = MATCH_NO;
350 : 1184260 : char c;
351 : :
352 : 1184260 : gfc_enforce_clean_symbol_state ();
353 : :
354 : 1184260 : gfc_clear_error (); /* Clear any pending errors. */
355 : 1184260 : gfc_clear_warning (); /* Clear any pending warnings. */
356 : :
357 : 1184260 : current_interface_ptr = get_current_interface_ptr ();
358 : 2368520 : previous_interface_head = current_interface_ptr == nullptr
359 : 1184260 : ? nullptr
360 : : : *current_interface_ptr;
361 : :
362 : 1184260 : gfc_matching_function = false;
363 : :
364 : 1184260 : if (gfc_match_eos () == MATCH_YES)
365 : : return ST_NONE;
366 : :
367 : 1184247 : if (gfc_current_state () == COMP_FUNCTION
368 : 90578 : && gfc_current_block ()->result->ts.kind == -1)
369 : 10278 : return decode_specification_statement ();
370 : :
371 : 1173969 : old_locus = gfc_current_locus;
372 : :
373 : 1173969 : c = gfc_peek_ascii_char ();
374 : :
375 : 1173969 : if (c == 'u')
376 : : {
377 : 24408 : if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
378 : : {
379 : 20751 : last_was_use_stmt = true;
380 : 20751 : return ST_USE;
381 : : }
382 : : else
383 : 3657 : undo_new_statement ();
384 : : }
385 : :
386 : 1153218 : if (last_was_use_stmt)
387 : 17627 : use_modules ();
388 : :
389 : : /* Try matching a data declaration or function declaration. The
390 : : input "REALFUNCTIONA(N)" can mean several things in different
391 : : contexts, so it (and its relatives) get special treatment. */
392 : :
393 : 1153216 : if (gfc_current_state () == COMP_NONE
394 : : || gfc_current_state () == COMP_INTERFACE
395 : : || gfc_current_state () == COMP_CONTAINS)
396 : : {
397 : 119595 : gfc_matching_function = true;
398 : 119595 : m = gfc_match_function_decl ();
399 : 119595 : if (m == MATCH_YES)
400 : : return ST_FUNCTION;
401 : 101382 : else if (m == MATCH_ERROR)
402 : 9225 : reject_statement ();
403 : : else
404 : 92157 : gfc_undo_symbols ();
405 : 101382 : gfc_current_locus = old_locus;
406 : : }
407 : 1135003 : gfc_matching_function = false;
408 : :
409 : : /* Legacy parameter statements are ambiguous with assignments so try parameter
410 : : first. */
411 : 1135003 : match ("parameter", gfc_match_parameter, ST_PARAMETER);
412 : :
413 : : /* Match statements whose error messages are meant to be overwritten
414 : : by something better. */
415 : :
416 : 1128238 : match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
417 : 948415 : match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
418 : :
419 : 939867 : if (in_specification_block)
420 : : {
421 : 387137 : m = match_word (NULL, gfc_match_st_function, &old_locus);
422 : 387137 : if (m == MATCH_YES)
423 : : return ST_STATEMENT_FUNCTION;
424 : : }
425 : :
426 : 939643 : if (!(in_specification_block && m == MATCH_ERROR))
427 : : {
428 : 939624 : match (NULL, gfc_match_ptr_fcn_assign, ST_ASSIGNMENT);
429 : : }
430 : :
431 : 939487 : match (NULL, gfc_match_data_decl, ST_DATA_DECL);
432 : 741932 : match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
433 : :
434 : : /* Try to match a subroutine statement, which has the same optional
435 : : prefixes that functions can have. */
436 : :
437 : 741676 : if (gfc_match_subroutine () == MATCH_YES)
438 : : return ST_SUBROUTINE;
439 : 701587 : gfc_undo_symbols ();
440 : 701587 : gfc_current_locus = old_locus;
441 : :
442 : 701587 : if (gfc_match_submod_proc () == MATCH_YES)
443 : : {
444 : 178 : if (gfc_new_block->attr.subroutine)
445 : : return ST_SUBROUTINE;
446 : 52 : else if (gfc_new_block->attr.function)
447 : : return ST_FUNCTION;
448 : : }
449 : 701409 : gfc_undo_symbols ();
450 : 701409 : gfc_current_locus = old_locus;
451 : :
452 : : /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
453 : : statements, which might begin with a block label. The match functions for
454 : : these statements are unusual in that their keyword is not seen before
455 : : the matcher is called. */
456 : :
457 : 701409 : if (gfc_match_if (&st) == MATCH_YES)
458 : 203332 : return st;
459 : 498077 : gfc_undo_symbols ();
460 : 498077 : gfc_current_locus = old_locus;
461 : :
462 : 498077 : if (gfc_match_where (&st) == MATCH_YES)
463 : 443 : return st;
464 : 497634 : gfc_undo_symbols ();
465 : 497634 : gfc_current_locus = old_locus;
466 : :
467 : 497634 : if (gfc_match_forall (&st) == MATCH_YES)
468 : 1998 : return st;
469 : 495636 : gfc_undo_symbols ();
470 : 495636 : gfc_current_locus = old_locus;
471 : :
472 : : /* Try to match TYPE as an alias for PRINT. */
473 : 495636 : if (gfc_match_type (&st) == MATCH_YES)
474 : 19 : return st;
475 : 495617 : gfc_undo_symbols ();
476 : 495617 : gfc_current_locus = old_locus;
477 : :
478 : 495617 : match (NULL, gfc_match_do, ST_DO);
479 : 464417 : match (NULL, gfc_match_block, ST_BLOCK);
480 : 463194 : match (NULL, gfc_match_associate, ST_ASSOCIATE);
481 : 461916 : match (NULL, gfc_match_critical, ST_CRITICAL);
482 : 461883 : match (NULL, gfc_match_select, ST_SELECT_CASE);
483 : 461330 : match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
484 : 458470 : match (NULL, gfc_match_select_rank, ST_SELECT_RANK);
485 : :
486 : : /* General statement matching: Instead of testing every possible
487 : : statement, we eliminate most possibilities by peeking at the
488 : : first character. */
489 : :
490 : 457452 : switch (c)
491 : : {
492 : 14226 : case 'a':
493 : 14226 : match ("abstract% interface", gfc_match_abstract_interface,
494 : : ST_INTERFACE);
495 : 13791 : match ("allocate", gfc_match_allocate, ST_ALLOCATE);
496 : 421 : match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
497 : 282 : match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
498 : 158 : match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
499 : 152 : match ("automatic", gfc_match_automatic, ST_ATTR_DECL);
500 : 145 : break;
501 : :
502 : 612 : case 'b':
503 : 612 : match ("backspace", gfc_match_backspace, ST_BACKSPACE);
504 : 210 : match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
505 : 126 : match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
506 : 25 : break;
507 : :
508 : 104102 : case 'c':
509 : 104102 : match ("call", gfc_match_call, ST_CALL);
510 : 27859 : match ("change% team", gfc_match_change_team, ST_CHANGE_TEAM);
511 : 27839 : match ("close", gfc_match_close, ST_CLOSE);
512 : 24777 : match ("continue", gfc_match_continue, ST_CONTINUE);
513 : 22022 : match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
514 : 22018 : match ("cycle", gfc_match_cycle, ST_CYCLE);
515 : 21988 : match ("case", gfc_match_case, ST_CASE);
516 : 20348 : match ("common", gfc_match_common, ST_COMMON);
517 : 18361 : match ("contains", gfc_match_eos, ST_CONTAINS);
518 : 2131 : match ("class", gfc_match_class_is, ST_CLASS_IS);
519 : 261 : match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
520 : 250 : break;
521 : :
522 : 8400 : case 'd':
523 : 8400 : match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
524 : 3169 : match ("data", gfc_match_data, ST_DATA);
525 : 721 : match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
526 : 90 : break;
527 : :
528 : 180544 : case 'e':
529 : 180544 : match ("end file", gfc_match_endfile, ST_END_FILE);
530 : 180473 : match ("end team", gfc_match_end_team, ST_END_TEAM);
531 : 180453 : match ("exit", gfc_match_exit, ST_EXIT);
532 : 180165 : match ("else", gfc_match_else, ST_ELSE);
533 : 176241 : match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
534 : 175929 : match ("else if", gfc_match_elseif, ST_ELSEIF);
535 : 174004 : match ("error% stop", gfc_match_error_stop, ST_ERROR_STOP);
536 : 173107 : match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
537 : :
538 : 172949 : if (gfc_match_end (&st) == MATCH_YES)
539 : 167770 : return st;
540 : :
541 : 5179 : match ("entry% ", gfc_match_entry, ST_ENTRY);
542 : 4427 : match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
543 : 3406 : match ("external", gfc_match_external, ST_ATTR_DECL);
544 : 319 : match ("event% post", gfc_match_event_post, ST_EVENT_POST);
545 : 296 : match ("event% wait", gfc_match_event_wait, ST_EVENT_WAIT);
546 : 280 : break;
547 : :
548 : 1556 : case 'f':
549 : 1556 : match ("fail% image", gfc_match_fail_image, ST_FAIL_IMAGE);
550 : 1552 : match ("final", gfc_match_final_decl, ST_FINAL);
551 : 1175 : match ("flush", gfc_match_flush, ST_FLUSH);
552 : 1085 : match ("form% team", gfc_match_form_team, ST_FORM_TEAM);
553 : 1055 : match ("format", gfc_match_format, ST_FORMAT);
554 : 44 : break;
555 : :
556 : 1487 : case 'g':
557 : 1487 : match ("generic", gfc_match_generic, ST_GENERIC);
558 : 630 : match ("go to", gfc_match_goto, ST_GOTO);
559 : 11 : break;
560 : :
561 : 37411 : case 'i':
562 : 37411 : match ("inquire", gfc_match_inquire, ST_INQUIRE);
563 : 36502 : match ("implicit", gfc_match_implicit, ST_IMPLICIT);
564 : 36068 : match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
565 : 13881 : match ("import", gfc_match_import, ST_IMPORT);
566 : 11158 : match ("interface", gfc_match_interface, ST_INTERFACE);
567 : 2046 : match ("intent", gfc_match_intent, ST_ATTR_DECL);
568 : 1951 : match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
569 : 501 : break;
570 : :
571 : 71 : case 'l':
572 : 71 : match ("lock", gfc_match_lock, ST_LOCK);
573 : 18 : break;
574 : :
575 : 10832 : case 'm':
576 : 10832 : match ("map", gfc_match_map, ST_MAP);
577 : 10574 : match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC);
578 : 9188 : match ("module", gfc_match_module, ST_MODULE);
579 : 25 : break;
580 : :
581 : 1571 : case 'n':
582 : 1571 : match ("nullify", gfc_match_nullify, ST_NULLIFY);
583 : 992 : match ("namelist", gfc_match_namelist, ST_NAMELIST);
584 : 18 : break;
585 : :
586 : 4106 : case 'o':
587 : 4106 : match ("open", gfc_match_open, ST_OPEN);
588 : 237 : match ("optional", gfc_match_optional, ST_ATTR_DECL);
589 : 25 : break;
590 : :
591 : 35040 : case 'p':
592 : 35040 : match ("print", gfc_match_print, ST_WRITE);
593 : 28394 : match ("pause", gfc_match_pause, ST_PAUSE);
594 : 28366 : match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
595 : 27493 : if (gfc_match_private (&st) == MATCH_YES)
596 : 1475 : return st;
597 : 26018 : match ("procedure", gfc_match_procedure, ST_PROCEDURE);
598 : 20012 : match ("program", gfc_match_program, ST_PROGRAM);
599 : 1559 : if (gfc_match_public (&st) == MATCH_YES)
600 : 1339 : return st;
601 : 220 : match ("protected", gfc_match_protected, ST_ATTR_DECL);
602 : 203 : break;
603 : :
604 : 13442 : case 'r':
605 : 13442 : match ("rank", gfc_match_rank_is, ST_RANK);
606 : 11140 : match ("read", gfc_match_read, ST_READ);
607 : 5020 : match ("return", gfc_match_return, ST_RETURN);
608 : 2313 : match ("rewind", gfc_match_rewind, ST_REWIND);
609 : 148 : break;
610 : :
611 : 10432 : case 's':
612 : 10432 : match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL);
613 : 10134 : match ("sequence", gfc_match_eos, ST_SEQUENCE);
614 : 9889 : match ("stop", gfc_match_stop, ST_STOP);
615 : 1335 : match ("save", gfc_match_save, ST_ATTR_DECL);
616 : 1067 : match ("static", gfc_match_static, ST_ATTR_DECL);
617 : 1066 : match ("submodule", gfc_match_submodule, ST_SUBMODULE);
618 : 865 : match ("sync% all", gfc_match_sync_all, ST_SYNC_ALL);
619 : 260 : match ("sync% images", gfc_match_sync_images, ST_SYNC_IMAGES);
620 : 182 : match ("sync% memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
621 : 118 : match ("sync% team", gfc_match_sync_team, ST_SYNC_TEAM);
622 : 117 : break;
623 : :
624 : 15244 : case 't':
625 : 15244 : match ("target", gfc_match_target, ST_ATTR_DECL);
626 : 15149 : match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
627 : 3408 : match ("type% is", gfc_match_type_is, ST_TYPE_IS);
628 : 141 : break;
629 : :
630 : 205 : case 'u':
631 : 205 : match ("union", gfc_match_union, ST_UNION);
632 : 73 : match ("unlock", gfc_match_unlock, ST_UNLOCK);
633 : 29 : break;
634 : :
635 : 174 : case 'v':
636 : 174 : match ("value", gfc_match_value, ST_ATTR_DECL);
637 : 95 : match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
638 : 19 : break;
639 : :
640 : 17952 : case 'w':
641 : 17952 : match ("wait", gfc_match_wait, ST_WAIT);
642 : 17863 : match ("write", gfc_match_write, ST_WRITE);
643 : 27 : break;
644 : : }
645 : :
646 : : /* All else has failed, so give up. See if any of the matchers has
647 : : stored an error message of some sort. Suppress the "Unclassifiable
648 : : statement" if a previous error message was emitted, e.g., by
649 : : gfc_error_now (). */
650 : 2161 : if (!gfc_error_check ())
651 : : {
652 : 53 : int ecnt;
653 : 53 : gfc_get_errors (NULL, &ecnt);
654 : 53 : if (ecnt <= 0)
655 : 18 : gfc_error_now ("Unclassifiable statement at %C");
656 : : }
657 : :
658 : 2158 : reject_statement ();
659 : :
660 : 2158 : gfc_error_recovery ();
661 : :
662 : 2158 : return ST_NONE;
663 : : }
664 : :
665 : : /* Like match and if spec_only, goto do_spec_only without actually
666 : : matching. */
667 : : /* If the directive matched but the clauses failed, do not start
668 : : matching the next directive in the same switch statement. */
669 : : #define matcha(keyword, subr, st) \
670 : : do { \
671 : : match m2; \
672 : : if (spec_only && gfc_match (keyword) == MATCH_YES) \
673 : : goto do_spec_only; \
674 : : else if ((m2 = match_word (keyword, subr, &old_locus)) \
675 : : == MATCH_YES) \
676 : : return st; \
677 : : else if (m2 == MATCH_ERROR) \
678 : : goto error_handling; \
679 : : else \
680 : : undo_new_statement (); \
681 : : } while (0)
682 : :
683 : : static gfc_statement
684 : 19433 : decode_oacc_directive (void)
685 : : {
686 : 19433 : locus old_locus;
687 : 19433 : char c;
688 : 19433 : bool spec_only = false;
689 : :
690 : 19433 : gfc_enforce_clean_symbol_state ();
691 : :
692 : 19433 : gfc_clear_error (); /* Clear any pending errors. */
693 : 19433 : gfc_clear_warning (); /* Clear any pending warnings. */
694 : :
695 : 19433 : gfc_matching_function = false;
696 : :
697 : 19433 : if (gfc_current_state () == COMP_FUNCTION
698 : 255 : && gfc_current_block ()->result->ts.kind == -1)
699 : 19433 : spec_only = true;
700 : :
701 : 19433 : old_locus = gfc_current_locus;
702 : :
703 : : /* General OpenACC directive matching: Instead of testing every possible
704 : : statement, we eliminate most possibilities by peeking at the
705 : : first character. */
706 : :
707 : 19433 : c = gfc_peek_ascii_char ();
708 : :
709 : 19433 : switch (c)
710 : : {
711 : 700 : case 'r':
712 : 700 : matcha ("routine", gfc_match_oacc_routine, ST_OACC_ROUTINE);
713 : 0 : break;
714 : : }
715 : :
716 : 18733 : gfc_unset_implicit_pure (NULL);
717 : 18733 : if (gfc_pure (NULL))
718 : : {
719 : 4 : gfc_error_now ("OpenACC directives other than ROUTINE may not appear in PURE "
720 : : "procedures at %C");
721 : 4 : goto error_handling;
722 : : }
723 : :
724 : 18729 : switch (c)
725 : : {
726 : 552 : case 'a':
727 : 552 : matcha ("atomic", gfc_match_oacc_atomic, ST_OACC_ATOMIC);
728 : 0 : break;
729 : 90 : case 'c':
730 : 90 : matcha ("cache", gfc_match_oacc_cache, ST_OACC_CACHE);
731 : 0 : break;
732 : 832 : case 'd':
733 : 832 : matcha ("data", gfc_match_oacc_data, ST_OACC_DATA);
734 : 173 : match ("declare", gfc_match_oacc_declare, ST_OACC_DECLARE);
735 : 16 : break;
736 : 7515 : case 'e':
737 : 7515 : matcha ("end atomic", gfc_match_omp_eos_error, ST_OACC_END_ATOMIC);
738 : 7003 : matcha ("end data", gfc_match_omp_eos_error, ST_OACC_END_DATA);
739 : 6347 : matcha ("end host_data", gfc_match_omp_eos_error, ST_OACC_END_HOST_DATA);
740 : 6285 : matcha ("end kernels loop", gfc_match_omp_eos_error, ST_OACC_END_KERNELS_LOOP);
741 : 6261 : matcha ("end kernels", gfc_match_omp_eos_error, ST_OACC_END_KERNELS);
742 : 5383 : matcha ("end loop", gfc_match_omp_eos_error, ST_OACC_END_LOOP);
743 : 5376 : matcha ("end parallel loop", gfc_match_omp_eos_error,
744 : : ST_OACC_END_PARALLEL_LOOP);
745 : 4447 : matcha ("end parallel", gfc_match_omp_eos_error, ST_OACC_END_PARALLEL);
746 : 1514 : matcha ("end serial loop", gfc_match_omp_eos_error,
747 : : ST_OACC_END_SERIAL_LOOP);
748 : 1510 : matcha ("end serial", gfc_match_omp_eos_error, ST_OACC_END_SERIAL);
749 : 1440 : matcha ("enter data", gfc_match_oacc_enter_data, ST_OACC_ENTER_DATA);
750 : 583 : matcha ("exit data", gfc_match_oacc_exit_data, ST_OACC_EXIT_DATA);
751 : 1 : break;
752 : 65 : case 'h':
753 : 65 : matcha ("host_data", gfc_match_oacc_host_data, ST_OACC_HOST_DATA);
754 : 0 : break;
755 : 4336 : case 'p':
756 : 4336 : matcha ("parallel loop", gfc_match_oacc_parallel_loop,
757 : : ST_OACC_PARALLEL_LOOP);
758 : 2958 : matcha ("parallel", gfc_match_oacc_parallel, ST_OACC_PARALLEL);
759 : 0 : break;
760 : 1029 : case 'k':
761 : 1029 : matcha ("kernels loop", gfc_match_oacc_kernels_loop,
762 : : ST_OACC_KERNELS_LOOP);
763 : 901 : matcha ("kernels", gfc_match_oacc_kernels, ST_OACC_KERNELS);
764 : 0 : break;
765 : 3274 : case 'l':
766 : 3274 : matcha ("loop", gfc_match_oacc_loop, ST_OACC_LOOP);
767 : 0 : break;
768 : 76 : case 's':
769 : 76 : matcha ("serial loop", gfc_match_oacc_serial_loop, ST_OACC_SERIAL_LOOP);
770 : 72 : matcha ("serial", gfc_match_oacc_serial, ST_OACC_SERIAL);
771 : 1 : break;
772 : 760 : case 'u':
773 : 760 : matcha ("update", gfc_match_oacc_update, ST_OACC_UPDATE);
774 : 0 : break;
775 : 198 : case 'w':
776 : 198 : matcha ("wait", gfc_match_oacc_wait, ST_OACC_WAIT);
777 : 0 : break;
778 : : }
779 : :
780 : : /* Directive not found or stored an error message.
781 : : Check and give up. */
782 : :
783 : 410 : error_handling:
784 : 410 : if (gfc_error_check () == 0)
785 : 5 : gfc_error_now ("Unclassifiable OpenACC directive at %C");
786 : :
787 : 410 : reject_statement ();
788 : :
789 : 410 : gfc_error_recovery ();
790 : :
791 : 410 : return ST_NONE;
792 : :
793 : 28 : do_spec_only:
794 : 28 : reject_statement ();
795 : 28 : gfc_clear_error ();
796 : 28 : gfc_buffer_error (false);
797 : 28 : gfc_current_locus = old_locus;
798 : 28 : return ST_GET_FCN_CHARACTERISTICS;
799 : : }
800 : :
801 : : /* Checks for the ST_OMP_ALLOCATE. First, check whether all list items
802 : : are allocatables/pointers - and if so, assume it is associated with a Fortran
803 : : ALLOCATE stmt. If not, do some initial parsing-related checks and append
804 : : namelist to namespace.
805 : : The check follows OpenMP 5.1 by requiring an executable stmt or OpenMP
806 : : construct before a directive associated with an allocate statement
807 : : (-> ST_OMP_ALLOCATE_EXEC); instead of showing an error, conversion of
808 : : ST_OMP_ALLOCATE -> ST_OMP_ALLOCATE_EXEC would be an alternative. */
809 : :
810 : : bool
811 : 114 : check_omp_allocate_stmt (locus *loc)
812 : : {
813 : 114 : gfc_omp_namelist *n;
814 : :
815 : 114 : if (new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym == NULL)
816 : : {
817 : 1 : gfc_error ("%qs directive at %L must either have a variable argument or, "
818 : : "if associated with an ALLOCATE stmt, must be preceded by an "
819 : : "executable statement or OpenMP construct",
820 : : gfc_ascii_statement (ST_OMP_ALLOCATE), loc);
821 : 1 : return false;
822 : : }
823 : : bool has_allocatable = false;
824 : : bool has_non_allocatable = false;
825 : 253 : for (n = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next)
826 : : {
827 : 140 : if (n->expr)
828 : : {
829 : 0 : gfc_error ("Structure-component expression at %L in %qs directive not"
830 : : " permitted in declarative directive; as directive "
831 : : "associated with an ALLOCATE stmt it must be preceded by "
832 : : "an executable statement or OpenMP construct",
833 : 0 : &n->expr->where, gfc_ascii_statement (ST_OMP_ALLOCATE));
834 : 0 : return false;
835 : : }
836 : : /* Procedure pointers are not allocatable; hence, we do not regard them as
837 : : pointers here - and reject them later in gfc_resolve_omp_allocate. */
838 : 140 : bool alloc_ptr;
839 : 140 : if (n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok)
840 : 0 : alloc_ptr = (CLASS_DATA (n->sym)->attr.allocatable
841 : 0 : || CLASS_DATA (n->sym)->attr.class_pointer);
842 : : else
843 : 140 : alloc_ptr = n->sym->attr.allocatable || n->sym->attr.pointer;
844 : 140 : if (alloc_ptr
845 : 135 : || (n->sym->ns && n->sym->ns->proc_name
846 : 135 : && (n->sym->ns->proc_name->attr.allocatable
847 : 135 : || n->sym->ns->proc_name->attr.pointer)))
848 : : has_allocatable = true;
849 : : else
850 : 140 : has_non_allocatable = true;
851 : : }
852 : : /* All allocatables - assume it is allocated with an ALLOCATE stmt. */
853 : 113 : if (has_allocatable && !has_non_allocatable)
854 : : {
855 : 3 : gfc_error ("%qs directive at %L associated with an ALLOCATE stmt must be "
856 : : "preceded by an executable statement or OpenMP construct; "
857 : : "note the variables in the list all have the allocatable or "
858 : : "pointer attribute", gfc_ascii_statement (ST_OMP_ALLOCATE),
859 : : loc);
860 : 3 : return false;
861 : : }
862 : 110 : if (!gfc_current_ns->omp_allocate)
863 : 55 : gfc_current_ns->omp_allocate
864 : 55 : = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
865 : : else
866 : : {
867 : 173 : for (n = gfc_current_ns->omp_allocate; n->next; n = n->next)
868 : : ;
869 : 55 : n->next = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
870 : : }
871 : 110 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = NULL;
872 : 110 : gfc_free_omp_clauses (new_st.ext.omp_clauses);
873 : 110 : return true;
874 : : }
875 : :
876 : :
877 : : /* Like match, but set a flag simd_matched if keyword matched
878 : : and if spec_only, goto do_spec_only without actually matching. */
879 : : #define matchs(keyword, subr, st) \
880 : : do { \
881 : : match m2; \
882 : : if (spec_only && gfc_match (keyword) == MATCH_YES) \
883 : : goto do_spec_only; \
884 : : if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \
885 : : &simd_matched)) == MATCH_YES) \
886 : : { \
887 : : ret = st; \
888 : : goto finish; \
889 : : } \
890 : : else if (m2 == MATCH_ERROR) \
891 : : goto error_handling; \
892 : : else \
893 : : undo_new_statement (); \
894 : : } while (0)
895 : :
896 : : /* Like match, but don't match anything if not -fopenmp
897 : : and if spec_only, goto do_spec_only without actually matching. */
898 : : /* If the directive matched but the clauses failed, do not start
899 : : matching the next directive in the same switch statement. */
900 : : #define matcho(keyword, subr, st) \
901 : : do { \
902 : : match m2; \
903 : : if (!flag_openmp) \
904 : : ; \
905 : : else if (spec_only && gfc_match (keyword) == MATCH_YES) \
906 : : goto do_spec_only; \
907 : : else if ((m2 = match_word (keyword, subr, &old_locus)) \
908 : : == MATCH_YES) \
909 : : { \
910 : : ret = st; \
911 : : goto finish; \
912 : : } \
913 : : else if (m2 == MATCH_ERROR) \
914 : : goto error_handling; \
915 : : else \
916 : : undo_new_statement (); \
917 : : } while (0)
918 : :
919 : : /* Like match, but set a flag simd_matched if keyword matched. */
920 : : #define matchds(keyword, subr, st) \
921 : : do { \
922 : : match m2; \
923 : : if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \
924 : : &simd_matched)) == MATCH_YES) \
925 : : { \
926 : : ret = st; \
927 : : goto finish; \
928 : : } \
929 : : else if (m2 == MATCH_ERROR) \
930 : : goto error_handling; \
931 : : else \
932 : : undo_new_statement (); \
933 : : } while (0)
934 : :
935 : : /* Like match, but don't match anything if not -fopenmp. */
936 : : #define matchdo(keyword, subr, st) \
937 : : do { \
938 : : match m2; \
939 : : if (!flag_openmp) \
940 : : ; \
941 : : else if ((m2 = match_word (keyword, subr, &old_locus)) \
942 : : == MATCH_YES) \
943 : : { \
944 : : ret = st; \
945 : : goto finish; \
946 : : } \
947 : : else if (m2 == MATCH_ERROR) \
948 : : goto error_handling; \
949 : : else \
950 : : undo_new_statement (); \
951 : : } while (0)
952 : :
953 : : static gfc_statement
954 : 31579 : decode_omp_directive (void)
955 : : {
956 : 31579 : locus old_locus;
957 : 31579 : char c;
958 : 31579 : bool simd_matched = false;
959 : 31579 : bool spec_only = false;
960 : 31579 : gfc_statement ret = ST_NONE;
961 : 31579 : bool pure_ok = true;
962 : :
963 : 31579 : gfc_enforce_clean_symbol_state ();
964 : :
965 : 31579 : gfc_clear_error (); /* Clear any pending errors. */
966 : 31579 : gfc_clear_warning (); /* Clear any pending warnings. */
967 : :
968 : 31579 : gfc_matching_function = false;
969 : :
970 : 31579 : if (gfc_current_state () == COMP_FUNCTION
971 : 1404 : && gfc_current_block ()->result->ts.kind == -1)
972 : 31579 : spec_only = true;
973 : :
974 : 31579 : old_locus = gfc_current_locus;
975 : :
976 : : /* General OpenMP directive matching: Instead of testing every possible
977 : : statement, we eliminate most possibilities by peeking at the
978 : : first character. */
979 : :
980 : 31579 : c = gfc_peek_ascii_char ();
981 : :
982 : : /* match is for directives that should be recognized only if
983 : : -fopenmp, matchs for directives that should be recognized
984 : : if either -fopenmp or -fopenmp-simd.
985 : : Handle only the directives allowed in PURE procedures
986 : : first (those also shall not turn off implicit pure). */
987 : 31579 : switch (c)
988 : : {
989 : 2452 : case 'a':
990 : : /* For -fopenmp-simd, ignore 'assumes'; note no clause starts with 's'. */
991 : 2452 : if (!flag_openmp && gfc_match ("assumes") == MATCH_YES)
992 : : break;
993 : 2450 : matcho ("assumes", gfc_match_omp_assumes, ST_OMP_ASSUMES);
994 : 2415 : matchs ("assume", gfc_match_omp_assume, ST_OMP_ASSUME);
995 : 2396 : break;
996 : 3268 : case 'd':
997 : 3268 : matchds ("declare reduction", gfc_match_omp_declare_reduction,
998 : : ST_OMP_DECLARE_REDUCTION);
999 : 2736 : matchds ("declare simd", gfc_match_omp_declare_simd,
1000 : : ST_OMP_DECLARE_SIMD);
1001 : 2543 : matchdo ("declare target", gfc_match_omp_declare_target,
1002 : : ST_OMP_DECLARE_TARGET);
1003 : 2100 : matchdo ("declare variant", gfc_match_omp_declare_variant,
1004 : : ST_OMP_DECLARE_VARIANT);
1005 : : break;
1006 : 9312 : case 'e':
1007 : 9312 : matchs ("end assume", gfc_match_omp_eos_error, ST_OMP_END_ASSUME);
1008 : 9303 : matchs ("end simd", gfc_match_omp_eos_error, ST_OMP_END_SIMD);
1009 : 9251 : matchs ("end tile", gfc_match_omp_eos_error, ST_OMP_END_TILE);
1010 : 9205 : matchs ("end unroll", gfc_match_omp_eos_error, ST_OMP_END_UNROLL);
1011 : 9164 : matcho ("error", gfc_match_omp_error, ST_OMP_ERROR);
1012 : : break;
1013 : 8 : case 'n':
1014 : 8 : matcho ("nothing", gfc_match_omp_nothing, ST_NONE);
1015 : : break;
1016 : 1824 : case 's':
1017 : 1824 : matchs ("scan", gfc_match_omp_scan, ST_OMP_SCAN);
1018 : 1773 : matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
1019 : 986 : break;
1020 : 8091 : case 't':
1021 : 8091 : matchs ("tile", gfc_match_omp_tile, ST_OMP_TILE);
1022 : 7888 : break;
1023 : 424 : case 'u':
1024 : 424 : matchs ("unroll", gfc_match_omp_unroll, ST_OMP_UNROLL);
1025 : 0 : break;
1026 : : }
1027 : :
1028 : 28286 : pure_ok = false;
1029 : 28286 : if (flag_openmp && gfc_pure (NULL))
1030 : : {
1031 : 15 : gfc_error_now ("OpenMP directive at %C is not pure and thus may not "
1032 : : "appear in a PURE procedure");
1033 : 15 : gfc_error_recovery ();
1034 : 15 : return ST_NONE;
1035 : : }
1036 : :
1037 : : /* match is for directives that should be recognized only if
1038 : : -fopenmp, matchs for directives that should be recognized
1039 : : if either -fopenmp or -fopenmp-simd. */
1040 : 28271 : switch (c)
1041 : : {
1042 : 2398 : case 'a':
1043 : 2398 : if (in_exec_part)
1044 : 2045 : matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE_EXEC);
1045 : : else
1046 : 353 : matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE);
1047 : 2213 : matcho ("allocators", gfc_match_omp_allocators, ST_OMP_ALLOCATORS);
1048 : 2188 : matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
1049 : : break;
1050 : 609 : case 'b':
1051 : 609 : matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
1052 : : break;
1053 : 661 : case 'c':
1054 : 661 : matcho ("cancellation% point", gfc_match_omp_cancellation_point,
1055 : : ST_OMP_CANCELLATION_POINT);
1056 : 488 : matcho ("cancel", gfc_match_omp_cancel, ST_OMP_CANCEL);
1057 : 167 : matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
1058 : : break;
1059 : 1735 : case 'd':
1060 : 1735 : matcho ("depobj", gfc_match_omp_depobj, ST_OMP_DEPOBJ);
1061 : 1612 : matcho ("dispatch", gfc_match_omp_dispatch, ST_OMP_DISPATCH);
1062 : 1530 : matchs ("distribute parallel do simd",
1063 : : gfc_match_omp_distribute_parallel_do_simd,
1064 : : ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD);
1065 : 1496 : matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do,
1066 : : ST_OMP_DISTRIBUTE_PARALLEL_DO);
1067 : 1459 : matchs ("distribute simd", gfc_match_omp_distribute_simd,
1068 : : ST_OMP_DISTRIBUTE_SIMD);
1069 : 1407 : matcho ("distribute", gfc_match_omp_distribute, ST_OMP_DISTRIBUTE);
1070 : 1350 : matchs ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD);
1071 : 1213 : matcho ("do", gfc_match_omp_do, ST_OMP_DO);
1072 : : break;
1073 : 9070 : case 'e':
1074 : 9070 : matcho ("end allocators", gfc_match_omp_eos_error, ST_OMP_END_ALLOCATORS);
1075 : 9065 : matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC);
1076 : 8830 : matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL);
1077 : 8670 : matcho ("end dispatch", gfc_match_omp_end_nowait, ST_OMP_END_DISPATCH);
1078 : 8665 : matchs ("end distribute parallel do simd", gfc_match_omp_eos_error,
1079 : : ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD);
1080 : 8658 : matcho ("end distribute parallel do", gfc_match_omp_eos_error,
1081 : : ST_OMP_END_DISTRIBUTE_PARALLEL_DO);
1082 : 8651 : matchs ("end distribute simd", gfc_match_omp_eos_error,
1083 : : ST_OMP_END_DISTRIBUTE_SIMD);
1084 : 8644 : matcho ("end distribute", gfc_match_omp_eos_error, ST_OMP_END_DISTRIBUTE);
1085 : 8629 : matchs ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD);
1086 : 8596 : matcho ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
1087 : 8337 : matchs ("end loop", gfc_match_omp_eos_error, ST_OMP_END_LOOP);
1088 : 8333 : matcho ("end masked taskloop simd", gfc_match_omp_eos_error,
1089 : : ST_OMP_END_MASKED_TASKLOOP_SIMD);
1090 : 8322 : matcho ("end masked taskloop", gfc_match_omp_eos_error,
1091 : : ST_OMP_END_MASKED_TASKLOOP);
1092 : 8315 : matcho ("end masked", gfc_match_omp_eos_error, ST_OMP_END_MASKED);
1093 : 8267 : matcho ("end master taskloop simd", gfc_match_omp_eos_error,
1094 : : ST_OMP_END_MASTER_TASKLOOP_SIMD);
1095 : 8262 : matcho ("end master taskloop", gfc_match_omp_eos_error,
1096 : : ST_OMP_END_MASTER_TASKLOOP);
1097 : 8257 : matcho ("end master", gfc_match_omp_eos_error, ST_OMP_END_MASTER);
1098 : 8147 : matchs ("end ordered", gfc_match_omp_eos_error, ST_OMP_END_ORDERED);
1099 : 7912 : matchs ("end parallel do simd", gfc_match_omp_eos_error,
1100 : : ST_OMP_END_PARALLEL_DO_SIMD);
1101 : 7870 : matcho ("end parallel do", gfc_match_omp_eos_error,
1102 : : ST_OMP_END_PARALLEL_DO);
1103 : 7673 : matcho ("end parallel loop", gfc_match_omp_eos_error,
1104 : : ST_OMP_END_PARALLEL_LOOP);
1105 : 7672 : matcho ("end parallel masked taskloop simd", gfc_match_omp_eos_error,
1106 : : ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD);
1107 : 7664 : matcho ("end parallel masked taskloop", gfc_match_omp_eos_error,
1108 : : ST_OMP_END_PARALLEL_MASKED_TASKLOOP);
1109 : 7657 : matcho ("end parallel masked", gfc_match_omp_eos_error,
1110 : : ST_OMP_END_PARALLEL_MASKED);
1111 : 7643 : matcho ("end parallel master taskloop simd", gfc_match_omp_eos_error,
1112 : : ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD);
1113 : 7637 : matcho ("end parallel master taskloop", gfc_match_omp_eos_error,
1114 : : ST_OMP_END_PARALLEL_MASTER_TASKLOOP);
1115 : 7632 : matcho ("end parallel master", gfc_match_omp_eos_error,
1116 : : ST_OMP_END_PARALLEL_MASTER);
1117 : 7618 : matcho ("end parallel sections", gfc_match_omp_eos_error,
1118 : : ST_OMP_END_PARALLEL_SECTIONS);
1119 : 7558 : matcho ("end parallel workshare", gfc_match_omp_eos_error,
1120 : : ST_OMP_END_PARALLEL_WORKSHARE);
1121 : 7502 : matcho ("end parallel", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL);
1122 : 5432 : matcho ("end scope", gfc_match_omp_end_nowait, ST_OMP_END_SCOPE);
1123 : 5372 : matcho ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
1124 : 5291 : matcho ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
1125 : 4716 : matcho ("end target data", gfc_match_omp_eos_error, ST_OMP_END_TARGET_DATA);
1126 : 3326 : matchs ("end target parallel do simd", gfc_match_omp_end_nowait,
1127 : : ST_OMP_END_TARGET_PARALLEL_DO_SIMD);
1128 : 3317 : matcho ("end target parallel do", gfc_match_omp_end_nowait,
1129 : : ST_OMP_END_TARGET_PARALLEL_DO);
1130 : 3308 : matcho ("end target parallel loop", gfc_match_omp_end_nowait,
1131 : : ST_OMP_END_TARGET_PARALLEL_LOOP);
1132 : 3301 : matcho ("end target parallel", gfc_match_omp_end_nowait,
1133 : : ST_OMP_END_TARGET_PARALLEL);
1134 : 3281 : matchs ("end target simd", gfc_match_omp_end_nowait, ST_OMP_END_TARGET_SIMD);
1135 : 3262 : matchs ("end target teams distribute parallel do simd",
1136 : : gfc_match_omp_end_nowait,
1137 : : ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
1138 : 3244 : matcho ("end target teams distribute parallel do", gfc_match_omp_end_nowait,
1139 : : ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO);
1140 : 3229 : matchs ("end target teams distribute simd", gfc_match_omp_end_nowait,
1141 : : ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD);
1142 : 3220 : matcho ("end target teams distribute", gfc_match_omp_end_nowait,
1143 : : ST_OMP_END_TARGET_TEAMS_DISTRIBUTE);
1144 : 3211 : matcho ("end target teams loop", gfc_match_omp_end_nowait,
1145 : : ST_OMP_END_TARGET_TEAMS_LOOP);
1146 : 3203 : matcho ("end target teams", gfc_match_omp_end_nowait,
1147 : : ST_OMP_END_TARGET_TEAMS);
1148 : 3137 : matcho ("end target", gfc_match_omp_end_nowait, ST_OMP_END_TARGET);
1149 : 1582 : matcho ("end taskgroup", gfc_match_omp_eos_error, ST_OMP_END_TASKGROUP);
1150 : 1395 : matchs ("end taskloop simd", gfc_match_omp_eos_error,
1151 : : ST_OMP_END_TASKLOOP_SIMD);
1152 : 1383 : matcho ("end taskloop", gfc_match_omp_eos_error, ST_OMP_END_TASKLOOP);
1153 : 1365 : matcho ("end task", gfc_match_omp_eos_error, ST_OMP_END_TASK);
1154 : 267 : matchs ("end teams distribute parallel do simd", gfc_match_omp_eos_error,
1155 : : ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
1156 : 259 : matcho ("end teams distribute parallel do", gfc_match_omp_eos_error,
1157 : : ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO);
1158 : 250 : matchs ("end teams distribute simd", gfc_match_omp_eos_error,
1159 : : ST_OMP_END_TEAMS_DISTRIBUTE_SIMD);
1160 : 219 : matcho ("end teams distribute", gfc_match_omp_eos_error,
1161 : : ST_OMP_END_TEAMS_DISTRIBUTE);
1162 : 210 : matcho ("end teams loop", gfc_match_omp_eos_error, ST_OMP_END_TEAMS_LOOP);
1163 : 209 : matcho ("end teams", gfc_match_omp_eos_error, ST_OMP_END_TEAMS);
1164 : 63 : matcho ("end workshare", gfc_match_omp_end_nowait,
1165 : : ST_OMP_END_WORKSHARE);
1166 : : break;
1167 : 84 : case 'f':
1168 : 84 : matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
1169 : : break;
1170 : 96 : case 'i':
1171 : 96 : matcho ("interop", gfc_match_omp_interop, ST_OMP_INTEROP);
1172 : : break;
1173 : 224 : case 'm':
1174 : 224 : matcho ("masked taskloop simd", gfc_match_omp_masked_taskloop_simd,
1175 : : ST_OMP_MASKED_TASKLOOP_SIMD);
1176 : 209 : matcho ("masked taskloop", gfc_match_omp_masked_taskloop,
1177 : : ST_OMP_MASKED_TASKLOOP);
1178 : 199 : matcho ("masked", gfc_match_omp_masked, ST_OMP_MASKED);
1179 : 150 : matcho ("master taskloop simd", gfc_match_omp_master_taskloop_simd,
1180 : : ST_OMP_MASTER_TASKLOOP_SIMD);
1181 : 128 : matcho ("master taskloop", gfc_match_omp_master_taskloop,
1182 : : ST_OMP_MASTER_TASKLOOP);
1183 : 112 : matcho ("master", gfc_match_omp_master, ST_OMP_MASTER);
1184 : : break;
1185 : 0 : case 'n':
1186 : 0 : matcho ("nothing", gfc_match_omp_nothing, ST_NONE);
1187 : : break;
1188 : 70 : case 'l':
1189 : 70 : matchs ("loop", gfc_match_omp_loop, ST_OMP_LOOP);
1190 : 0 : break;
1191 : 552 : case 'o':
1192 : 552 : if (gfc_match ("ordered depend (") == MATCH_YES
1193 : 552 : || gfc_match ("ordered doacross (") == MATCH_YES)
1194 : : {
1195 : 317 : gfc_current_locus = old_locus;
1196 : 317 : if (!flag_openmp)
1197 : : break;
1198 : 315 : matcho ("ordered", gfc_match_omp_ordered_depend,
1199 : : ST_OMP_ORDERED_DEPEND);
1200 : : }
1201 : : else
1202 : 235 : matchs ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
1203 : : break;
1204 : 3769 : case 'p':
1205 : 3769 : matchs ("parallel do simd", gfc_match_omp_parallel_do_simd,
1206 : : ST_OMP_PARALLEL_DO_SIMD);
1207 : 3479 : matcho ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
1208 : 2319 : matcho ("parallel loop", gfc_match_omp_parallel_loop,
1209 : : ST_OMP_PARALLEL_LOOP);
1210 : 2304 : matcho ("parallel masked taskloop simd",
1211 : : gfc_match_omp_parallel_masked_taskloop_simd,
1212 : : ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD);
1213 : 2291 : matcho ("parallel masked taskloop",
1214 : : gfc_match_omp_parallel_masked_taskloop,
1215 : : ST_OMP_PARALLEL_MASKED_TASKLOOP);
1216 : 2281 : matcho ("parallel masked", gfc_match_omp_parallel_masked,
1217 : : ST_OMP_PARALLEL_MASKED);
1218 : 2267 : matcho ("parallel master taskloop simd",
1219 : : gfc_match_omp_parallel_master_taskloop_simd,
1220 : : ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD);
1221 : 2246 : matcho ("parallel master taskloop",
1222 : : gfc_match_omp_parallel_master_taskloop,
1223 : : ST_OMP_PARALLEL_MASTER_TASKLOOP);
1224 : 2231 : matcho ("parallel master", gfc_match_omp_parallel_master,
1225 : : ST_OMP_PARALLEL_MASTER);
1226 : 2217 : matcho ("parallel sections", gfc_match_omp_parallel_sections,
1227 : : ST_OMP_PARALLEL_SECTIONS);
1228 : 2158 : matcho ("parallel workshare", gfc_match_omp_parallel_workshare,
1229 : : ST_OMP_PARALLEL_WORKSHARE);
1230 : 2102 : matcho ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
1231 : : break;
1232 : 94 : case 'r':
1233 : 94 : matcho ("requires", gfc_match_omp_requires, ST_OMP_REQUIRES);
1234 : : break;
1235 : 986 : case 's':
1236 : 986 : matcho ("scope", gfc_match_omp_scope, ST_OMP_SCOPE);
1237 : 928 : matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
1238 : 846 : matcho ("section", gfc_match_omp_eos_error, ST_OMP_SECTION);
1239 : 588 : matcho ("single", gfc_match_omp_single, ST_OMP_SINGLE);
1240 : : break;
1241 : 7882 : case 't':
1242 : 7882 : matcho ("target data", gfc_match_omp_target_data, ST_OMP_TARGET_DATA);
1243 : 6481 : matcho ("target enter data", gfc_match_omp_target_enter_data,
1244 : : ST_OMP_TARGET_ENTER_DATA);
1245 : 6187 : matcho ("target exit data", gfc_match_omp_target_exit_data,
1246 : : ST_OMP_TARGET_EXIT_DATA);
1247 : 5973 : matchs ("target parallel do simd", gfc_match_omp_target_parallel_do_simd,
1248 : : ST_OMP_TARGET_PARALLEL_DO_SIMD);
1249 : 5954 : matcho ("target parallel do", gfc_match_omp_target_parallel_do,
1250 : : ST_OMP_TARGET_PARALLEL_DO);
1251 : 5886 : matcho ("target parallel loop", gfc_match_omp_target_parallel_loop,
1252 : : ST_OMP_TARGET_PARALLEL_LOOP);
1253 : 5870 : matcho ("target parallel", gfc_match_omp_target_parallel,
1254 : : ST_OMP_TARGET_PARALLEL);
1255 : 5846 : matchs ("target simd", gfc_match_omp_target_simd, ST_OMP_TARGET_SIMD);
1256 : 5812 : matchs ("target teams distribute parallel do simd",
1257 : : gfc_match_omp_target_teams_distribute_parallel_do_simd,
1258 : : ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
1259 : 5779 : matcho ("target teams distribute parallel do",
1260 : : gfc_match_omp_target_teams_distribute_parallel_do,
1261 : : ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO);
1262 : 5726 : matchs ("target teams distribute simd",
1263 : : gfc_match_omp_target_teams_distribute_simd,
1264 : : ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD);
1265 : 5705 : matcho ("target teams distribute", gfc_match_omp_target_teams_distribute,
1266 : : ST_OMP_TARGET_TEAMS_DISTRIBUTE);
1267 : 5687 : matcho ("target teams loop", gfc_match_omp_target_teams_loop,
1268 : : ST_OMP_TARGET_TEAMS_LOOP);
1269 : 5670 : matcho ("target teams", gfc_match_omp_target_teams, ST_OMP_TARGET_TEAMS);
1270 : 5604 : matcho ("target update", gfc_match_omp_target_update,
1271 : : ST_OMP_TARGET_UPDATE);
1272 : 3895 : matcho ("target", gfc_match_omp_target, ST_OMP_TARGET);
1273 : 2193 : matcho ("taskgroup", gfc_match_omp_taskgroup, ST_OMP_TASKGROUP);
1274 : 2005 : matchs ("taskloop simd", gfc_match_omp_taskloop_simd,
1275 : : ST_OMP_TASKLOOP_SIMD);
1276 : 1965 : matcho ("taskloop", gfc_match_omp_taskloop, ST_OMP_TASKLOOP);
1277 : 1873 : matcho ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
1278 : 1728 : matcho ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD);
1279 : 1718 : matcho ("task", gfc_match_omp_task, ST_OMP_TASK);
1280 : 538 : matchs ("teams distribute parallel do simd",
1281 : : gfc_match_omp_teams_distribute_parallel_do_simd,
1282 : : ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
1283 : 476 : matcho ("teams distribute parallel do",
1284 : : gfc_match_omp_teams_distribute_parallel_do,
1285 : : ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO);
1286 : 437 : matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd,
1287 : : ST_OMP_TEAMS_DISTRIBUTE_SIMD);
1288 : 393 : matcho ("teams distribute", gfc_match_omp_teams_distribute,
1289 : : ST_OMP_TEAMS_DISTRIBUTE);
1290 : 371 : matcho ("teams loop", gfc_match_omp_teams_loop, ST_OMP_TEAMS_LOOP);
1291 : 359 : matcho ("teams", gfc_match_omp_teams, ST_OMP_TEAMS);
1292 : 212 : matchdo ("threadprivate", gfc_match_omp_threadprivate,
1293 : : ST_OMP_THREADPRIVATE);
1294 : : break;
1295 : 40 : case 'w':
1296 : 40 : matcho ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
1297 : : break;
1298 : : }
1299 : :
1300 : : /* All else has failed, so give up. See if any of the matchers has
1301 : : stored an error message of some sort. Don't error out if
1302 : : not -fopenmp and simd_matched is false, i.e. if a directive other
1303 : : than one marked with match has been seen. */
1304 : :
1305 : 2 : error_handling:
1306 : 524 : if (flag_openmp || simd_matched)
1307 : : {
1308 : 461 : if (!gfc_error_check ())
1309 : 16 : gfc_error_now ("Unclassifiable OpenMP directive at %C");
1310 : : }
1311 : :
1312 : 524 : reject_statement ();
1313 : :
1314 : 524 : gfc_error_recovery ();
1315 : :
1316 : 524 : return ST_NONE;
1317 : :
1318 : 31021 : finish:
1319 : 31021 : if (ret == ST_OMP_ERROR && new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
1320 : : {
1321 : 33 : gfc_unset_implicit_pure (NULL);
1322 : :
1323 : 33 : if (gfc_pure (NULL))
1324 : : {
1325 : 1 : gfc_error_now ("OpenMP ERROR directive at %L with %<at(execution)%> "
1326 : : "clause in a PURE procedure", &old_locus);
1327 : 1 : reject_statement ();
1328 : 1 : gfc_error_recovery ();
1329 : 1 : return ST_NONE;
1330 : : }
1331 : : }
1332 : 31020 : if (!pure_ok)
1333 : : {
1334 : 27873 : gfc_unset_implicit_pure (NULL);
1335 : :
1336 : 27873 : if (!flag_openmp && gfc_pure (NULL))
1337 : : {
1338 : 3 : gfc_error_now ("OpenMP directive at %C is not pure and thus may not "
1339 : : "appear in a PURE procedure");
1340 : 3 : reject_statement ();
1341 : 3 : gfc_error_recovery ();
1342 : 3 : return ST_NONE;
1343 : : }
1344 : : }
1345 : 31017 : if (ret == ST_OMP_ALLOCATE && !check_omp_allocate_stmt (&old_locus))
1346 : 4 : goto error_handling;
1347 : :
1348 : 31013 : switch (ret)
1349 : : {
1350 : : /* For the constraints on clauses with the global requirement property,
1351 : : we set omp_target_seen. This included all clauses that take the
1352 : : DEVICE clause, (BEGIN) DECLARE_TARGET and procedures run the device
1353 : : (which effectively is implied by the former). */
1354 : 6119 : case ST_OMP_DECLARE_TARGET:
1355 : 6119 : case ST_OMP_INTEROP:
1356 : 6119 : case ST_OMP_TARGET:
1357 : 6119 : case ST_OMP_TARGET_DATA:
1358 : 6119 : case ST_OMP_TARGET_ENTER_DATA:
1359 : 6119 : case ST_OMP_TARGET_EXIT_DATA:
1360 : 6119 : case ST_OMP_TARGET_TEAMS:
1361 : 6119 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
1362 : 6119 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
1363 : 6119 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
1364 : 6119 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1365 : 6119 : case ST_OMP_TARGET_TEAMS_LOOP:
1366 : 6119 : case ST_OMP_TARGET_PARALLEL:
1367 : 6119 : case ST_OMP_TARGET_PARALLEL_DO:
1368 : 6119 : case ST_OMP_TARGET_PARALLEL_DO_SIMD:
1369 : 6119 : case ST_OMP_TARGET_PARALLEL_LOOP:
1370 : 6119 : case ST_OMP_TARGET_SIMD:
1371 : 6119 : case ST_OMP_TARGET_UPDATE:
1372 : 6119 : {
1373 : 6119 : gfc_namespace *prog_unit = gfc_current_ns;
1374 : 10224 : while (prog_unit->parent)
1375 : : {
1376 : 4113 : if (gfc_state_stack->previous
1377 : 4113 : && gfc_state_stack->previous->state == COMP_INTERFACE)
1378 : : break;
1379 : : prog_unit = prog_unit->parent;
1380 : : }
1381 : 6119 : prog_unit->omp_target_seen = true;
1382 : 6119 : break;
1383 : : }
1384 : 405 : case ST_OMP_ALLOCATE_EXEC:
1385 : 405 : case ST_OMP_ALLOCATORS:
1386 : 405 : case ST_OMP_TEAMS:
1387 : 405 : case ST_OMP_TEAMS_DISTRIBUTE:
1388 : 405 : case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
1389 : 405 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
1390 : 405 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1391 : 405 : case ST_OMP_TEAMS_LOOP:
1392 : 1519 : for (gfc_state_data *stk = gfc_state_stack->previous; stk;
1393 : 1114 : stk = stk->previous)
1394 : 1114 : if (stk && stk->tail)
1395 : 342 : switch (stk->tail->op)
1396 : : {
1397 : 189 : case EXEC_OMP_TARGET:
1398 : 189 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
1399 : 189 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
1400 : 189 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
1401 : 189 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1402 : 189 : case EXEC_OMP_TARGET_TEAMS_LOOP:
1403 : 189 : case EXEC_OMP_TARGET_PARALLEL:
1404 : 189 : case EXEC_OMP_TARGET_PARALLEL_DO:
1405 : 189 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
1406 : 189 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
1407 : 189 : case EXEC_OMP_TARGET_SIMD:
1408 : 189 : if (ret == ST_OMP_ALLOCATE_EXEC || ret == ST_OMP_ALLOCATORS)
1409 : 4 : new_st.ext.omp_clauses->contained_in_target_construct = 1;
1410 : : else
1411 : 185 : stk->tail->ext.omp_clauses->contains_teams_construct = 1;
1412 : : break;
1413 : : default:
1414 : : break;
1415 : : }
1416 : : break;
1417 : 62 : case ST_OMP_ERROR:
1418 : 62 : if (new_st.ext.omp_clauses->at != OMP_AT_EXECUTION)
1419 : : return ST_NONE;
1420 : : default:
1421 : : break;
1422 : : }
1423 : : return ret;
1424 : :
1425 : 23 : do_spec_only:
1426 : 23 : reject_statement ();
1427 : 23 : gfc_clear_error ();
1428 : 23 : gfc_buffer_error (false);
1429 : 23 : gfc_current_locus = old_locus;
1430 : 23 : return ST_GET_FCN_CHARACTERISTICS;
1431 : : }
1432 : :
1433 : : static gfc_statement
1434 : 3295533 : decode_gcc_attribute (void)
1435 : : {
1436 : 3295533 : locus old_locus;
1437 : :
1438 : 3295533 : gfc_enforce_clean_symbol_state ();
1439 : :
1440 : 3295533 : gfc_clear_error (); /* Clear any pending errors. */
1441 : 3295533 : gfc_clear_warning (); /* Clear any pending warnings. */
1442 : 3295533 : old_locus = gfc_current_locus;
1443 : :
1444 : 3295533 : match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL);
1445 : 3292873 : match ("unroll", gfc_match_gcc_unroll, ST_NONE);
1446 : 3292856 : match ("builtin", gfc_match_gcc_builtin, ST_NONE);
1447 : 12 : match ("ivdep", gfc_match_gcc_ivdep, ST_NONE);
1448 : 9 : match ("vector", gfc_match_gcc_vector, ST_NONE);
1449 : 6 : match ("novector", gfc_match_gcc_novector, ST_NONE);
1450 : :
1451 : : /* All else has failed, so give up. See if any of the matchers has
1452 : : stored an error message of some sort. */
1453 : :
1454 : 3 : if (!gfc_error_check ())
1455 : : {
1456 : 1 : if (pedantic)
1457 : 0 : gfc_error_now ("Unclassifiable GCC directive at %C");
1458 : : else
1459 : 1 : gfc_warning_now (0, "Unclassifiable GCC directive at %C, ignored");
1460 : : }
1461 : :
1462 : 3 : reject_statement ();
1463 : :
1464 : 3 : gfc_error_recovery ();
1465 : :
1466 : 3 : return ST_NONE;
1467 : : }
1468 : :
1469 : : #undef match
1470 : :
1471 : : /* Assert next length characters to be equal to token in free form. */
1472 : :
1473 : : static void
1474 : 49931 : verify_token_free (const char* token, int length, bool last_was_use_stmt)
1475 : : {
1476 : 49931 : int i;
1477 : 49931 : char c;
1478 : :
1479 : 49931 : c = gfc_next_ascii_char ();
1480 : 299359 : for (i = 0; i < length; i++, c = gfc_next_ascii_char ())
1481 : 199497 : gcc_assert (c == token[i]);
1482 : :
1483 : 49931 : gcc_assert (gfc_is_whitespace(c));
1484 : 49931 : gfc_gobble_whitespace ();
1485 : 49931 : if (last_was_use_stmt)
1486 : 92 : use_modules ();
1487 : 49931 : }
1488 : :
1489 : : /* Get the next statement in free form source. */
1490 : :
1491 : : static gfc_statement
1492 : 4257861 : next_free (void)
1493 : : {
1494 : 4257861 : match m;
1495 : 4257861 : int i, cnt, at_bol;
1496 : 4257861 : char c;
1497 : :
1498 : 4257861 : at_bol = gfc_at_bol ();
1499 : 4257861 : gfc_gobble_whitespace ();
1500 : :
1501 : 4257861 : c = gfc_peek_ascii_char ();
1502 : :
1503 : 4257861 : if (ISDIGIT (c))
1504 : : {
1505 : 2211 : char d;
1506 : :
1507 : : /* Found a statement label? */
1508 : 2211 : m = gfc_match_st_label (&gfc_statement_label);
1509 : :
1510 : 2211 : d = gfc_peek_ascii_char ();
1511 : 2211 : if (m != MATCH_YES || !gfc_is_whitespace (d))
1512 : : {
1513 : 4 : gfc_match_small_literal_int (&i, &cnt);
1514 : :
1515 : 4 : if (cnt > 5)
1516 : 1 : gfc_error_now ("Too many digits in statement label at %C");
1517 : :
1518 : 4 : if (i == 0)
1519 : 1 : gfc_error_now ("Zero is not a valid statement label at %C");
1520 : :
1521 : 4 : do
1522 : 4 : c = gfc_next_ascii_char ();
1523 : 4 : while (ISDIGIT(c));
1524 : :
1525 : 4 : if (!gfc_is_whitespace (c))
1526 : 2 : gfc_error_now ("Non-numeric character in statement label at %C");
1527 : :
1528 : 4 : return ST_NONE;
1529 : : }
1530 : : else
1531 : : {
1532 : 2207 : label_locus = gfc_current_locus;
1533 : :
1534 : 2207 : gfc_gobble_whitespace ();
1535 : :
1536 : 2207 : if (at_bol && gfc_peek_ascii_char () == ';')
1537 : : {
1538 : 2 : gfc_error_now ("Semicolon at %C needs to be preceded by "
1539 : : "statement");
1540 : 2 : gfc_next_ascii_char (); /* Eat up the semicolon. */
1541 : 2 : return ST_NONE;
1542 : : }
1543 : :
1544 : 2205 : if (gfc_match_eos () == MATCH_YES)
1545 : 2 : gfc_error_now ("Statement label without statement at %L",
1546 : : &label_locus);
1547 : : }
1548 : : }
1549 : 4255650 : else if (c == '!')
1550 : : {
1551 : : /* Comments have already been skipped by the time we get here,
1552 : : except for GCC attributes and OpenMP/OpenACC directives. */
1553 : :
1554 : 3151772 : gfc_next_ascii_char (); /* Eat up the exclamation sign. */
1555 : 3151772 : c = gfc_peek_ascii_char ();
1556 : :
1557 : 3151772 : if (c == 'g')
1558 : : {
1559 : 3101841 : int i;
1560 : :
1561 : 3101841 : c = gfc_next_ascii_char ();
1562 : 18611046 : for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
1563 : 12407364 : gcc_assert (c == "gcc$"[i]);
1564 : :
1565 : 3101841 : gfc_gobble_whitespace ();
1566 : 3101841 : return decode_gcc_attribute ();
1567 : :
1568 : : }
1569 : 49931 : else if (c == '$')
1570 : : {
1571 : : /* Since both OpenMP and OpenACC directives starts with
1572 : : !$ character sequence, we must check all flags combinations */
1573 : 49931 : if ((flag_openmp || flag_openmp_simd)
1574 : 31435 : && !flag_openacc)
1575 : : {
1576 : 31208 : verify_token_free ("$omp", 4, last_was_use_stmt);
1577 : 31208 : return decode_omp_directive ();
1578 : : }
1579 : 18723 : else if ((flag_openmp || flag_openmp_simd)
1580 : 227 : && flag_openacc)
1581 : : {
1582 : 227 : gfc_next_ascii_char (); /* Eat up dollar character */
1583 : 227 : c = gfc_peek_ascii_char ();
1584 : :
1585 : 227 : if (c == 'o')
1586 : : {
1587 : 97 : verify_token_free ("omp", 3, last_was_use_stmt);
1588 : 97 : return decode_omp_directive ();
1589 : : }
1590 : 130 : else if (c == 'a')
1591 : : {
1592 : 130 : verify_token_free ("acc", 3, last_was_use_stmt);
1593 : 130 : return decode_oacc_directive ();
1594 : : }
1595 : : }
1596 : 18496 : else if (flag_openacc)
1597 : : {
1598 : 18496 : verify_token_free ("$acc", 4, last_was_use_stmt);
1599 : 18496 : return decode_oacc_directive ();
1600 : : }
1601 : : }
1602 : 0 : gcc_unreachable ();
1603 : : }
1604 : :
1605 : 1106083 : if (at_bol && c == ';')
1606 : : {
1607 : 7 : if (!(gfc_option.allow_std & GFC_STD_F2008))
1608 : 2 : gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1609 : : "statement");
1610 : 7 : gfc_next_ascii_char (); /* Eat up the semicolon. */
1611 : 7 : return ST_NONE;
1612 : : }
1613 : :
1614 : 1106076 : return decode_statement ();
1615 : : }
1616 : :
1617 : : /* Assert next length characters to be equal to token in fixed form. */
1618 : :
1619 : : static bool
1620 : 1081 : verify_token_fixed (const char *token, int length, bool last_was_use_stmt)
1621 : : {
1622 : 1081 : int i;
1623 : 1081 : char c = gfc_next_char_literal (NONSTRING);
1624 : :
1625 : 4309 : for (i = 0; i < length; i++, c = gfc_next_char_literal (NONSTRING))
1626 : 3228 : gcc_assert ((char) gfc_wide_tolower (c) == token[i]);
1627 : :
1628 : 1081 : if (c != ' ' && c != '0')
1629 : : {
1630 : 0 : gfc_buffer_error (false);
1631 : 0 : gfc_error ("Bad continuation line at %C");
1632 : 0 : return false;
1633 : : }
1634 : 1081 : if (last_was_use_stmt)
1635 : 0 : use_modules ();
1636 : :
1637 : : return true;
1638 : : }
1639 : :
1640 : : /* Get the next statement in fixed-form source. */
1641 : :
1642 : : static gfc_statement
1643 : 272967 : next_fixed (void)
1644 : : {
1645 : 272967 : int label, digit_flag, i;
1646 : 272967 : locus loc;
1647 : 272967 : gfc_char_t c;
1648 : :
1649 : 272967 : if (!gfc_at_bol ())
1650 : 45 : return decode_statement ();
1651 : :
1652 : : /* Skip past the current label field, parsing a statement label if
1653 : : one is there. This is a weird number parser, since the number is
1654 : : contained within five columns and can have any kind of embedded
1655 : : spaces. We also check for characters that make the rest of the
1656 : : line a comment. */
1657 : :
1658 : : label = 0;
1659 : : digit_flag = 0;
1660 : :
1661 : 663652 : for (i = 0; i < 5; i++)
1662 : : {
1663 : 585506 : c = gfc_next_char_literal (NONSTRING);
1664 : :
1665 : 585506 : switch (c)
1666 : : {
1667 : : case ' ':
1668 : : break;
1669 : :
1670 : 6610 : case '0':
1671 : 6610 : case '1':
1672 : 6610 : case '2':
1673 : 6610 : case '3':
1674 : 6610 : case '4':
1675 : 6610 : case '5':
1676 : 6610 : case '6':
1677 : 6610 : case '7':
1678 : 6610 : case '8':
1679 : 6610 : case '9':
1680 : 6610 : label = label * 10 + ((unsigned char) c - '0');
1681 : 6610 : label_locus = gfc_current_locus;
1682 : 6610 : digit_flag = 1;
1683 : 6610 : break;
1684 : :
1685 : : /* Comments have already been skipped by the time we get
1686 : : here, except for GCC attributes and OpenMP directives. */
1687 : :
1688 : 194773 : case '*':
1689 : 194773 : c = gfc_next_char_literal (NONSTRING);
1690 : :
1691 : 194773 : if (TOLOWER (c) == 'g')
1692 : : {
1693 : 968460 : for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
1694 : 774768 : gcc_assert (TOLOWER (c) == "gcc$"[i]);
1695 : :
1696 : 193692 : return decode_gcc_attribute ();
1697 : : }
1698 : 1081 : else if (c == '$')
1699 : : {
1700 : 1081 : if ((flag_openmp || flag_openmp_simd)
1701 : 279 : && !flag_openacc)
1702 : : {
1703 : 264 : if (!verify_token_fixed ("omp", 3, last_was_use_stmt))
1704 : : return ST_NONE;
1705 : 264 : return decode_omp_directive ();
1706 : : }
1707 : 817 : else if ((flag_openmp || flag_openmp_simd)
1708 : 15 : && flag_openacc)
1709 : : {
1710 : 15 : c = gfc_next_char_literal(NONSTRING);
1711 : 15 : if (c == 'o' || c == 'O')
1712 : : {
1713 : 10 : if (!verify_token_fixed ("mp", 2, last_was_use_stmt))
1714 : : return ST_NONE;
1715 : 10 : return decode_omp_directive ();
1716 : : }
1717 : 5 : else if (c == 'a' || c == 'A')
1718 : : {
1719 : 5 : if (!verify_token_fixed ("cc", 2, last_was_use_stmt))
1720 : : return ST_NONE;
1721 : 5 : return decode_oacc_directive ();
1722 : : }
1723 : : }
1724 : 802 : else if (flag_openacc)
1725 : : {
1726 : 802 : if (!verify_token_fixed ("acc", 3, last_was_use_stmt))
1727 : : return ST_NONE;
1728 : 802 : return decode_oacc_directive ();
1729 : : }
1730 : : }
1731 : 3 : gcc_fallthrough ();
1732 : :
1733 : : /* Comments have already been skipped by the time we get
1734 : : here so don't bother checking for them. */
1735 : :
1736 : 3 : default:
1737 : 3 : gfc_buffer_error (false);
1738 : 3 : gfc_error ("Non-numeric character in statement label at %C");
1739 : 3 : return ST_NONE;
1740 : : }
1741 : : }
1742 : :
1743 : 78146 : if (digit_flag)
1744 : : {
1745 : 2445 : if (label == 0)
1746 : 1 : gfc_warning_now (0, "Zero is not a valid statement label at %C");
1747 : : else
1748 : : {
1749 : : /* We've found a valid statement label. */
1750 : 2444 : gfc_statement_label = gfc_get_st_label (label);
1751 : : }
1752 : : }
1753 : :
1754 : : /* Since this line starts a statement, it cannot be a continuation
1755 : : of a previous statement. If we see something here besides a
1756 : : space or zero, it must be a bad continuation line. */
1757 : :
1758 : 78146 : c = gfc_next_char_literal (NONSTRING);
1759 : 78146 : if (c == '\n')
1760 : 0 : goto blank_line;
1761 : :
1762 : 78146 : if (c != ' ' && c != '0')
1763 : : {
1764 : 0 : gfc_buffer_error (false);
1765 : 0 : gfc_error ("Bad continuation line at %C");
1766 : 0 : return ST_NONE;
1767 : : }
1768 : :
1769 : : /* Now that we've taken care of the statement label columns, we have
1770 : : to make sure that the first nonblank character is not a '!'. If
1771 : : it is, the rest of the line is a comment. */
1772 : :
1773 : 212857 : do
1774 : : {
1775 : 212857 : loc = gfc_current_locus;
1776 : 212857 : c = gfc_next_char_literal (NONSTRING);
1777 : : }
1778 : 212857 : while (gfc_is_whitespace (c));
1779 : :
1780 : 78146 : if (c == '!')
1781 : 0 : goto blank_line;
1782 : 78146 : gfc_current_locus = loc;
1783 : :
1784 : 78146 : if (c == ';')
1785 : : {
1786 : 6 : if (digit_flag)
1787 : 2 : gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1788 : 4 : else if (!(gfc_option.allow_std & GFC_STD_F2008))
1789 : 2 : gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1790 : : "statement");
1791 : 6 : return ST_NONE;
1792 : : }
1793 : :
1794 : 78140 : if (gfc_match_eos () == MATCH_YES)
1795 : 1 : goto blank_line;
1796 : :
1797 : : /* At this point, we've got a nonblank statement to parse. */
1798 : 78139 : return decode_statement ();
1799 : :
1800 : 1 : blank_line:
1801 : 1 : if (digit_flag)
1802 : 1 : gfc_error_now ("Statement label without statement at %L", &label_locus);
1803 : :
1804 : 1 : gfc_current_locus.u.lb->truncated = 0;
1805 : 1 : gfc_advance_line ();
1806 : 1 : return ST_NONE;
1807 : : }
1808 : :
1809 : :
1810 : : /* Return the next non-ST_NONE statement to the caller. We also worry
1811 : : about including files and the ends of include files at this stage. */
1812 : :
1813 : : static gfc_statement
1814 : 1265258 : next_statement (void)
1815 : : {
1816 : 1265258 : gfc_statement st;
1817 : 1265258 : locus old_locus;
1818 : :
1819 : 1265258 : gfc_enforce_clean_symbol_state ();
1820 : 1265258 : gfc_save_module_list ();
1821 : :
1822 : 1265258 : gfc_new_block = NULL;
1823 : :
1824 : 1265258 : gfc_current_ns->old_equiv = gfc_current_ns->equiv;
1825 : 1265258 : gfc_current_ns->old_data = gfc_current_ns->data;
1826 : 4561323 : for (;;)
1827 : : {
1828 : 4561323 : gfc_statement_label = NULL;
1829 : 4561323 : gfc_buffer_error (true);
1830 : :
1831 : 4561323 : if (gfc_at_eol ())
1832 : 4493735 : gfc_advance_line ();
1833 : :
1834 : 4561323 : gfc_skip_comments ();
1835 : :
1836 : 4561323 : if (gfc_at_end ())
1837 : : {
1838 : : st = ST_NONE;
1839 : : break;
1840 : : }
1841 : :
1842 : 4530836 : if (gfc_define_undef_line ())
1843 : 8 : continue;
1844 : :
1845 : 4530828 : old_locus = gfc_current_locus;
1846 : :
1847 : 4530828 : st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
1848 : :
1849 : 4530820 : if (st != ST_NONE)
1850 : : break;
1851 : : }
1852 : :
1853 : 1265250 : gfc_buffer_error (false);
1854 : :
1855 : 1265250 : if (st == ST_GET_FCN_CHARACTERISTICS)
1856 : : {
1857 : 6593 : if (gfc_statement_label != NULL)
1858 : : {
1859 : 3 : gfc_free_st_label (gfc_statement_label);
1860 : 3 : gfc_statement_label = NULL;
1861 : : }
1862 : 6593 : gfc_current_locus = old_locus;
1863 : : }
1864 : :
1865 : 1265250 : if (st != ST_NONE)
1866 : 1234763 : check_statement_label (st);
1867 : :
1868 : 1265250 : return st;
1869 : : }
1870 : :
1871 : :
1872 : : /****************************** Parser ***********************************/
1873 : :
1874 : : /* The parser subroutines are of type 'try' that fail if the file ends
1875 : : unexpectedly. */
1876 : :
1877 : : /* Macros that expand to case-labels for various classes of
1878 : : statements. Start with executable statements that directly do
1879 : : things. */
1880 : :
1881 : : #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1882 : : case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1883 : : case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1884 : : case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1885 : : case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1886 : : case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1887 : : case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1888 : : case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1889 : : case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1890 : : case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: case ST_OMP_DEPOBJ: \
1891 : : case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
1892 : : case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: case ST_OMP_ERROR: \
1893 : : case ST_OMP_INTEROP: \
1894 : : case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \
1895 : : case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1896 : : case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
1897 : : case ST_END_TEAM: case ST_SYNC_TEAM: \
1898 : : case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
1899 : : case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1900 : : case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1901 : :
1902 : : /* Statements that mark other executable statements. */
1903 : :
1904 : : #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1905 : : case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1906 : : case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1907 : : case ST_SELECT_RANK: case ST_OMP_PARALLEL: case ST_OMP_PARALLEL_MASKED: \
1908 : : case ST_OMP_PARALLEL_MASKED_TASKLOOP: \
1909 : : case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: case ST_OMP_PARALLEL_MASTER: \
1910 : : case ST_OMP_PARALLEL_MASTER_TASKLOOP: \
1911 : : case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: \
1912 : : case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1913 : : case ST_OMP_CRITICAL: case ST_OMP_MASKED: case ST_OMP_MASKED_TASKLOOP: \
1914 : : case ST_OMP_MASKED_TASKLOOP_SIMD: \
1915 : : case ST_OMP_MASTER: case ST_OMP_MASTER_TASKLOOP: \
1916 : : case ST_OMP_MASTER_TASKLOOP_SIMD: case ST_OMP_SCOPE: case ST_OMP_SINGLE: \
1917 : : case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1918 : : case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1919 : : case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1920 : : case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1921 : : case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1922 : : case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1923 : : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1924 : : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1925 : : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1926 : : case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1927 : : case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1928 : : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1929 : : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1930 : : case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1931 : : case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \
1932 : : case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \
1933 : : case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
1934 : : case ST_OMP_LOOP: case ST_OMP_PARALLEL_LOOP: case ST_OMP_TEAMS_LOOP: \
1935 : : case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_TEAMS_LOOP: \
1936 : : case ST_OMP_ALLOCATE_EXEC: case ST_OMP_ALLOCATORS: case ST_OMP_ASSUME: \
1937 : : case ST_OMP_TILE: case ST_OMP_UNROLL: case ST_OMP_DISPATCH: \
1938 : : case ST_CRITICAL: \
1939 : : case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1940 : : case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
1941 : : case ST_OACC_KERNELS_LOOP: case ST_OACC_SERIAL_LOOP: case ST_OACC_SERIAL: \
1942 : : case ST_OACC_ATOMIC
1943 : :
1944 : : /* Declaration statements */
1945 : :
1946 : : #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1947 : : case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1948 : : case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE
1949 : :
1950 : : /* OpenMP and OpenACC declaration statements, which may appear anywhere in
1951 : : the specification part. */
1952 : :
1953 : : #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
1954 : : case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \
1955 : : case ST_OMP_DECLARE_VARIANT: case ST_OMP_ALLOCATE: case ST_OMP_ASSUMES: \
1956 : : case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
1957 : :
1958 : : /* Block end statements. Errors associated with interchanging these
1959 : : are detected in gfc_match_end(). */
1960 : :
1961 : : #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1962 : : case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1963 : : case ST_END_BLOCK: case ST_END_ASSOCIATE
1964 : :
1965 : :
1966 : : /* Push a new state onto the stack. */
1967 : :
1968 : : static void
1969 : 211619 : push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
1970 : : {
1971 : 211619 : p->state = new_state;
1972 : 211619 : p->previous = gfc_state_stack;
1973 : 211619 : p->sym = sym;
1974 : 211619 : p->head = p->tail = NULL;
1975 : 211619 : p->do_variable = NULL;
1976 : 211619 : if (p->state != COMP_DO && p->state != COMP_DO_CONCURRENT)
1977 : 180419 : p->ext.oacc_declare_clauses = NULL;
1978 : :
1979 : : /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1980 : : construct statement was accepted right before pushing the state. Thus,
1981 : : the construct's gfc_code is available as tail of the parent state. */
1982 : 211619 : gcc_assert (gfc_state_stack);
1983 : 211619 : p->construct = gfc_state_stack->tail;
1984 : :
1985 : 211619 : gfc_state_stack = p;
1986 : 211619 : }
1987 : :
1988 : :
1989 : : /* Pop the current state. */
1990 : : static void
1991 : 211200 : pop_state (void)
1992 : : {
1993 : 211200 : gfc_state_stack = gfc_state_stack->previous;
1994 : 34593 : }
1995 : :
1996 : :
1997 : : /* Try to find the given state in the state stack. */
1998 : :
1999 : : bool
2000 : 3770489 : gfc_find_state (gfc_compile_state state)
2001 : : {
2002 : 3770489 : gfc_state_data *p;
2003 : :
2004 : 14824223 : for (p = gfc_state_stack; p; p = p->previous)
2005 : 11139052 : if (p->state == state)
2006 : : break;
2007 : :
2008 : 3770489 : return (p == NULL) ? false : true;
2009 : : }
2010 : :
2011 : :
2012 : : /* Starts a new level in the statement list. */
2013 : :
2014 : : static gfc_code *
2015 : 72108 : new_level (gfc_code *q)
2016 : : {
2017 : 72108 : gfc_code *p;
2018 : :
2019 : 72108 : p = q->block = gfc_get_code (EXEC_NOP);
2020 : :
2021 : 72108 : gfc_state_stack->head = gfc_state_stack->tail = p;
2022 : :
2023 : 72108 : return p;
2024 : : }
2025 : :
2026 : :
2027 : : /* Add the current new_st code structure and adds it to the current
2028 : : program unit. As a side-effect, it zeroes the new_st. */
2029 : :
2030 : : static gfc_code *
2031 : 706509 : add_statement (void)
2032 : : {
2033 : 706509 : gfc_code *p;
2034 : :
2035 : 706509 : p = XCNEW (gfc_code);
2036 : 706509 : *p = new_st;
2037 : :
2038 : 706509 : p->loc = gfc_current_locus;
2039 : :
2040 : 706509 : if (gfc_state_stack->head == NULL)
2041 : 96831 : gfc_state_stack->head = p;
2042 : : else
2043 : 609678 : gfc_state_stack->tail->next = p;
2044 : :
2045 : 707062 : while (p->next != NULL)
2046 : : p = p->next;
2047 : :
2048 : 706509 : gfc_state_stack->tail = p;
2049 : :
2050 : 706509 : gfc_clear_new_st ();
2051 : :
2052 : 706509 : return p;
2053 : : }
2054 : :
2055 : :
2056 : : /* Frees everything associated with the current statement. */
2057 : :
2058 : : static void
2059 : 25772181 : undo_new_statement (void)
2060 : : {
2061 : 25772181 : gfc_free_statements (new_st.block);
2062 : 25772181 : gfc_free_statements (new_st.next);
2063 : 25772181 : gfc_free_statement (&new_st);
2064 : 25772181 : gfc_clear_new_st ();
2065 : 25772181 : }
2066 : :
2067 : :
2068 : : /* If the current statement has a statement label, make sure that it
2069 : : is allowed to, or should have one. */
2070 : :
2071 : : static void
2072 : 1234763 : check_statement_label (gfc_statement st)
2073 : : {
2074 : 1234763 : gfc_sl_type type;
2075 : :
2076 : 1234763 : if (gfc_statement_label == NULL)
2077 : : {
2078 : 1230131 : if (st == ST_FORMAT)
2079 : 0 : gfc_error ("FORMAT statement at %L does not have a statement label",
2080 : : &new_st.loc);
2081 : 1230131 : return;
2082 : : }
2083 : :
2084 : 4632 : switch (st)
2085 : : {
2086 : 3614 : case ST_END_PROGRAM:
2087 : 3614 : case ST_END_FUNCTION:
2088 : 3614 : case ST_END_SUBROUTINE:
2089 : 3614 : case ST_ENDDO:
2090 : 3614 : case ST_ENDIF:
2091 : 3614 : case ST_END_SELECT:
2092 : 3614 : case ST_END_CRITICAL:
2093 : 3614 : case ST_END_BLOCK:
2094 : 3614 : case ST_END_ASSOCIATE:
2095 : 3614 : case_executable:
2096 : 3614 : case_exec_markers:
2097 : 3614 : if (st == ST_ENDDO || st == ST_CONTINUE)
2098 : : type = ST_LABEL_DO_TARGET;
2099 : : else
2100 : 955 : type = ST_LABEL_TARGET;
2101 : : break;
2102 : :
2103 : : case ST_FORMAT:
2104 : : type = ST_LABEL_FORMAT;
2105 : : break;
2106 : :
2107 : : /* Statement labels are not restricted from appearing on a
2108 : : particular line. However, there are plenty of situations
2109 : : where the resulting label can't be referenced. */
2110 : :
2111 : 7 : default:
2112 : 7 : type = ST_LABEL_BAD_TARGET;
2113 : 7 : break;
2114 : : }
2115 : :
2116 : 4632 : gfc_define_st_label (gfc_statement_label, type, &label_locus);
2117 : :
2118 : 4632 : new_st.here = gfc_statement_label;
2119 : : }
2120 : :
2121 : :
2122 : : /* Figures out what the enclosing program unit is. This will be a
2123 : : function, subroutine, program, block data or module. */
2124 : :
2125 : : gfc_state_data *
2126 : 941589 : gfc_enclosing_unit (gfc_compile_state * result)
2127 : : {
2128 : 941589 : gfc_state_data *p;
2129 : :
2130 : 1373371 : for (p = gfc_state_stack; p; p = p->previous)
2131 : 1330756 : if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
2132 : : || p->state == COMP_MODULE || p->state == COMP_SUBMODULE
2133 : : || p->state == COMP_BLOCK_DATA || p->state == COMP_PROGRAM)
2134 : : {
2135 : :
2136 : 898974 : if (result != NULL)
2137 : 3075 : *result = p->state;
2138 : 898974 : return p;
2139 : : }
2140 : :
2141 : 42615 : if (result != NULL)
2142 : 0 : *result = COMP_PROGRAM;
2143 : : return NULL;
2144 : : }
2145 : :
2146 : :
2147 : : /* Translate a statement enum to a string. If strip_sentinel is true,
2148 : : the !$OMP/!$ACC sentinel is excluded. */
2149 : :
2150 : : const char *
2151 : 26743 : gfc_ascii_statement (gfc_statement st, bool strip_sentinel)
2152 : : {
2153 : 26743 : const char *p;
2154 : :
2155 : 26743 : switch (st)
2156 : : {
2157 : 0 : case ST_ARITHMETIC_IF:
2158 : 0 : p = _("arithmetic IF");
2159 : 0 : break;
2160 : : case ST_ALLOCATE:
2161 : : p = "ALLOCATE";
2162 : : break;
2163 : 0 : case ST_ASSOCIATE:
2164 : 0 : p = "ASSOCIATE";
2165 : 0 : break;
2166 : 1 : case ST_ATTR_DECL:
2167 : 1 : p = _("attribute declaration");
2168 : 1 : break;
2169 : 2 : case ST_BACKSPACE:
2170 : 2 : p = "BACKSPACE";
2171 : 2 : break;
2172 : 1 : case ST_BLOCK:
2173 : 1 : p = "BLOCK";
2174 : 1 : break;
2175 : 1 : case ST_BLOCK_DATA:
2176 : 1 : p = "BLOCK DATA";
2177 : 1 : break;
2178 : 5 : case ST_CALL:
2179 : 5 : p = "CALL";
2180 : 5 : break;
2181 : 0 : case ST_CASE:
2182 : 0 : p = "CASE";
2183 : 0 : break;
2184 : 0 : case ST_CLOSE:
2185 : 0 : p = "CLOSE";
2186 : 0 : break;
2187 : 17 : case ST_COMMON:
2188 : 17 : p = "COMMON";
2189 : 17 : break;
2190 : 0 : case ST_CONTINUE:
2191 : 0 : p = "CONTINUE";
2192 : 0 : break;
2193 : 2 : case ST_CONTAINS:
2194 : 2 : p = "CONTAINS";
2195 : 2 : break;
2196 : 1 : case ST_CRITICAL:
2197 : 1 : p = "CRITICAL";
2198 : 1 : break;
2199 : 4 : case ST_CYCLE:
2200 : 4 : p = "CYCLE";
2201 : 4 : break;
2202 : 16 : case ST_DATA_DECL:
2203 : 16 : p = _("data declaration");
2204 : 16 : break;
2205 : 8 : case ST_DATA:
2206 : 8 : p = "DATA";
2207 : 8 : break;
2208 : 1 : case ST_DEALLOCATE:
2209 : 1 : p = "DEALLOCATE";
2210 : 1 : break;
2211 : 1 : case ST_MAP:
2212 : 1 : p = "MAP";
2213 : 1 : break;
2214 : 0 : case ST_UNION:
2215 : 0 : p = "UNION";
2216 : 0 : break;
2217 : 1 : case ST_STRUCTURE_DECL:
2218 : 1 : p = "STRUCTURE";
2219 : 1 : break;
2220 : 1 : case ST_DERIVED_DECL:
2221 : 1 : p = _("derived type declaration");
2222 : 1 : break;
2223 : 0 : case ST_DO:
2224 : 0 : p = "DO";
2225 : 0 : break;
2226 : 2 : case ST_ELSE:
2227 : 2 : p = "ELSE";
2228 : 2 : break;
2229 : 0 : case ST_ELSEIF:
2230 : 0 : p = "ELSE IF";
2231 : 0 : break;
2232 : 0 : case ST_ELSEWHERE:
2233 : 0 : p = "ELSEWHERE";
2234 : 0 : break;
2235 : 1 : case ST_EVENT_POST:
2236 : 1 : p = "EVENT POST";
2237 : 1 : break;
2238 : 0 : case ST_EVENT_WAIT:
2239 : 0 : p = "EVENT WAIT";
2240 : 0 : break;
2241 : 2 : case ST_FAIL_IMAGE:
2242 : 2 : p = "FAIL IMAGE";
2243 : 2 : break;
2244 : 0 : case ST_CHANGE_TEAM:
2245 : 0 : p = "CHANGE TEAM";
2246 : 0 : break;
2247 : 0 : case ST_END_TEAM:
2248 : 0 : p = "END TEAM";
2249 : 0 : break;
2250 : 0 : case ST_FORM_TEAM:
2251 : 0 : p = "FORM TEAM";
2252 : 0 : break;
2253 : 0 : case ST_SYNC_TEAM:
2254 : 0 : p = "SYNC TEAM";
2255 : 0 : break;
2256 : 4 : case ST_END_ASSOCIATE:
2257 : 4 : p = "END ASSOCIATE";
2258 : 4 : break;
2259 : 11 : case ST_END_BLOCK:
2260 : 11 : p = "END BLOCK";
2261 : 11 : break;
2262 : 1 : case ST_END_BLOCK_DATA:
2263 : 1 : p = "END BLOCK DATA";
2264 : 1 : break;
2265 : 0 : case ST_END_CRITICAL:
2266 : 0 : p = "END CRITICAL";
2267 : 0 : break;
2268 : 8 : case ST_ENDDO:
2269 : 8 : p = "END DO";
2270 : 8 : break;
2271 : 2 : case ST_END_FILE:
2272 : 2 : p = "END FILE";
2273 : 2 : break;
2274 : 2 : case ST_END_FORALL:
2275 : 2 : p = "END FORALL";
2276 : 2 : break;
2277 : 1092 : case ST_END_FUNCTION:
2278 : 1092 : p = "END FUNCTION";
2279 : 1092 : break;
2280 : 4 : case ST_ENDIF:
2281 : 4 : p = "END IF";
2282 : 4 : break;
2283 : 12 : case ST_END_INTERFACE:
2284 : 12 : p = "END INTERFACE";
2285 : 12 : break;
2286 : 24 : case ST_END_MODULE:
2287 : 24 : p = "END MODULE";
2288 : 24 : break;
2289 : 4 : case ST_END_SUBMODULE:
2290 : 4 : p = "END SUBMODULE";
2291 : 4 : break;
2292 : 68 : case ST_END_PROGRAM:
2293 : 68 : p = "END PROGRAM";
2294 : 68 : break;
2295 : 4 : case ST_END_SELECT:
2296 : 4 : p = "END SELECT";
2297 : 4 : break;
2298 : 2430 : case ST_END_SUBROUTINE:
2299 : 2430 : p = "END SUBROUTINE";
2300 : 2430 : break;
2301 : 2 : case ST_END_WHERE:
2302 : 2 : p = "END WHERE";
2303 : 2 : break;
2304 : 0 : case ST_END_STRUCTURE:
2305 : 0 : p = "END STRUCTURE";
2306 : 0 : break;
2307 : 0 : case ST_END_UNION:
2308 : 0 : p = "END UNION";
2309 : 0 : break;
2310 : 0 : case ST_END_MAP:
2311 : 0 : p = "END MAP";
2312 : 0 : break;
2313 : 0 : case ST_END_TYPE:
2314 : 0 : p = "END TYPE";
2315 : 0 : break;
2316 : 0 : case ST_ENTRY:
2317 : 0 : p = "ENTRY";
2318 : 0 : break;
2319 : 1 : case ST_EQUIVALENCE:
2320 : 1 : p = "EQUIVALENCE";
2321 : 1 : break;
2322 : 130 : case ST_ERROR_STOP:
2323 : 130 : p = "ERROR STOP";
2324 : 130 : break;
2325 : 11 : case ST_EXIT:
2326 : 11 : p = "EXIT";
2327 : 11 : break;
2328 : 2 : case ST_FLUSH:
2329 : 2 : p = "FLUSH";
2330 : 2 : break;
2331 : 0 : case ST_FORALL_BLOCK: /* Fall through */
2332 : 0 : case ST_FORALL:
2333 : 0 : p = "FORALL";
2334 : 0 : break;
2335 : 1 : case ST_FORMAT:
2336 : 1 : p = "FORMAT";
2337 : 1 : break;
2338 : 0 : case ST_FUNCTION:
2339 : 0 : p = "FUNCTION";
2340 : 0 : break;
2341 : 0 : case ST_GENERIC:
2342 : 0 : p = "GENERIC";
2343 : 0 : break;
2344 : 0 : case ST_GOTO:
2345 : 0 : p = "GOTO";
2346 : 0 : break;
2347 : 0 : case ST_IF_BLOCK:
2348 : 0 : p = _("block IF");
2349 : 0 : break;
2350 : 22353 : case ST_IMPLICIT:
2351 : 22353 : p = "IMPLICIT";
2352 : 22353 : break;
2353 : 3 : case ST_IMPLICIT_NONE:
2354 : 3 : p = "IMPLICIT NONE";
2355 : 3 : break;
2356 : 0 : case ST_IMPLIED_ENDDO:
2357 : 0 : p = _("implied END DO");
2358 : 0 : break;
2359 : 0 : case ST_IMPORT:
2360 : 0 : p = "IMPORT";
2361 : 0 : break;
2362 : 0 : case ST_INQUIRE:
2363 : 0 : p = "INQUIRE";
2364 : 0 : break;
2365 : 2 : case ST_INTERFACE:
2366 : 2 : p = "INTERFACE";
2367 : 2 : break;
2368 : 1 : case ST_LOCK:
2369 : 1 : p = "LOCK";
2370 : 1 : break;
2371 : 0 : case ST_PARAMETER:
2372 : 0 : p = "PARAMETER";
2373 : 0 : break;
2374 : 0 : case ST_PRIVATE:
2375 : 0 : p = "PRIVATE";
2376 : 0 : break;
2377 : 0 : case ST_PUBLIC:
2378 : 0 : p = "PUBLIC";
2379 : 0 : break;
2380 : 1 : case ST_MODULE:
2381 : 1 : p = "MODULE";
2382 : 1 : break;
2383 : 0 : case ST_SUBMODULE:
2384 : 0 : p = "SUBMODULE";
2385 : 0 : break;
2386 : 0 : case ST_PAUSE:
2387 : 0 : p = "PAUSE";
2388 : 0 : break;
2389 : 4 : case ST_MODULE_PROC:
2390 : 4 : p = "MODULE PROCEDURE";
2391 : 4 : break;
2392 : 2 : case ST_NAMELIST:
2393 : 2 : p = "NAMELIST";
2394 : 2 : break;
2395 : 0 : case ST_NULLIFY:
2396 : 0 : p = "NULLIFY";
2397 : 0 : break;
2398 : 0 : case ST_OPEN:
2399 : 0 : p = "OPEN";
2400 : 0 : break;
2401 : 1 : case ST_PROGRAM:
2402 : 1 : p = "PROGRAM";
2403 : 1 : break;
2404 : 0 : case ST_PROCEDURE:
2405 : 0 : p = "PROCEDURE";
2406 : 0 : break;
2407 : 0 : case ST_READ:
2408 : 0 : p = "READ";
2409 : 0 : break;
2410 : 0 : case ST_RETURN:
2411 : 0 : p = "RETURN";
2412 : 0 : break;
2413 : 2 : case ST_REWIND:
2414 : 2 : p = "REWIND";
2415 : 2 : break;
2416 : 36 : case ST_STOP:
2417 : 36 : p = "STOP";
2418 : 36 : break;
2419 : 0 : case ST_SYNC_ALL:
2420 : 0 : p = "SYNC ALL";
2421 : 0 : break;
2422 : 0 : case ST_SYNC_IMAGES:
2423 : 0 : p = "SYNC IMAGES";
2424 : 0 : break;
2425 : 0 : case ST_SYNC_MEMORY:
2426 : 0 : p = "SYNC MEMORY";
2427 : 0 : break;
2428 : 1 : case ST_SUBROUTINE:
2429 : 1 : p = "SUBROUTINE";
2430 : 1 : break;
2431 : 0 : case ST_TYPE:
2432 : 0 : p = "TYPE";
2433 : 0 : break;
2434 : 0 : case ST_UNLOCK:
2435 : 0 : p = "UNLOCK";
2436 : 0 : break;
2437 : 10 : case ST_USE:
2438 : 10 : p = "USE";
2439 : 10 : break;
2440 : 0 : case ST_WHERE_BLOCK: /* Fall through */
2441 : 0 : case ST_WHERE:
2442 : 0 : p = "WHERE";
2443 : 0 : break;
2444 : 0 : case ST_WAIT:
2445 : 0 : p = "WAIT";
2446 : 0 : break;
2447 : 1 : case ST_WRITE:
2448 : 1 : p = "WRITE";
2449 : 1 : break;
2450 : 13 : case ST_ASSIGNMENT:
2451 : 13 : p = _("assignment");
2452 : 13 : break;
2453 : 0 : case ST_POINTER_ASSIGNMENT:
2454 : 0 : p = _("pointer assignment");
2455 : 0 : break;
2456 : 0 : case ST_SELECT_CASE:
2457 : 0 : p = "SELECT CASE";
2458 : 0 : break;
2459 : 0 : case ST_SELECT_TYPE:
2460 : 0 : p = "SELECT TYPE";
2461 : 0 : break;
2462 : 0 : case ST_SELECT_RANK:
2463 : 0 : p = "SELECT RANK";
2464 : 0 : break;
2465 : 0 : case ST_TYPE_IS:
2466 : 0 : p = "TYPE IS";
2467 : 0 : break;
2468 : 0 : case ST_CLASS_IS:
2469 : 0 : p = "CLASS IS";
2470 : 0 : break;
2471 : 0 : case ST_RANK:
2472 : 0 : p = "RANK";
2473 : 0 : break;
2474 : 1 : case ST_SEQUENCE:
2475 : 1 : p = "SEQUENCE";
2476 : 1 : break;
2477 : 0 : case ST_SIMPLE_IF:
2478 : 0 : p = _("simple IF");
2479 : 0 : break;
2480 : 3 : case ST_STATEMENT_FUNCTION:
2481 : 3 : p = "STATEMENT FUNCTION";
2482 : 3 : break;
2483 : 0 : case ST_LABEL_ASSIGNMENT:
2484 : 0 : p = "LABEL ASSIGNMENT";
2485 : 0 : break;
2486 : 2 : case ST_ENUM:
2487 : 2 : p = "ENUM DEFINITION";
2488 : 2 : break;
2489 : 0 : case ST_ENUMERATOR:
2490 : 0 : p = "ENUMERATOR DEFINITION";
2491 : 0 : break;
2492 : 4 : case ST_END_ENUM:
2493 : 4 : p = "END ENUM";
2494 : 4 : break;
2495 : 0 : case ST_OACC_PARALLEL_LOOP:
2496 : 0 : p = "!$ACC PARALLEL LOOP";
2497 : 0 : break;
2498 : 3 : case ST_OACC_END_PARALLEL_LOOP:
2499 : 3 : p = "!$ACC END PARALLEL LOOP";
2500 : 3 : break;
2501 : 3 : case ST_OACC_PARALLEL:
2502 : 3 : p = "!$ACC PARALLEL";
2503 : 3 : break;
2504 : 37 : case ST_OACC_END_PARALLEL:
2505 : 37 : p = "!$ACC END PARALLEL";
2506 : 37 : break;
2507 : 49 : case ST_OACC_KERNELS:
2508 : 49 : p = "!$ACC KERNELS";
2509 : 49 : break;
2510 : 13 : case ST_OACC_END_KERNELS:
2511 : 13 : p = "!$ACC END KERNELS";
2512 : 13 : break;
2513 : 1 : case ST_OACC_KERNELS_LOOP:
2514 : 1 : p = "!$ACC KERNELS LOOP";
2515 : 1 : break;
2516 : 2 : case ST_OACC_END_KERNELS_LOOP:
2517 : 2 : p = "!$ACC END KERNELS LOOP";
2518 : 2 : break;
2519 : 0 : case ST_OACC_SERIAL_LOOP:
2520 : 0 : p = "!$ACC SERIAL LOOP";
2521 : 0 : break;
2522 : 1 : case ST_OACC_END_SERIAL_LOOP:
2523 : 1 : p = "!$ACC END SERIAL LOOP";
2524 : 1 : break;
2525 : 0 : case ST_OACC_SERIAL:
2526 : 0 : p = "!$ACC SERIAL";
2527 : 0 : break;
2528 : 4 : case ST_OACC_END_SERIAL:
2529 : 4 : p = "!$ACC END SERIAL";
2530 : 4 : break;
2531 : 2 : case ST_OACC_DATA:
2532 : 2 : p = "!$ACC DATA";
2533 : 2 : break;
2534 : 8 : case ST_OACC_END_DATA:
2535 : 8 : p = "!$ACC END DATA";
2536 : 8 : break;
2537 : 0 : case ST_OACC_HOST_DATA:
2538 : 0 : p = "!$ACC HOST_DATA";
2539 : 0 : break;
2540 : 2 : case ST_OACC_END_HOST_DATA:
2541 : 2 : p = "!$ACC END HOST_DATA";
2542 : 2 : break;
2543 : 4 : case ST_OACC_LOOP:
2544 : 4 : p = "!$ACC LOOP";
2545 : 4 : break;
2546 : 5 : case ST_OACC_END_LOOP:
2547 : 5 : p = "!$ACC END LOOP";
2548 : 5 : break;
2549 : 0 : case ST_OACC_DECLARE:
2550 : 0 : p = "!$ACC DECLARE";
2551 : 0 : break;
2552 : 1 : case ST_OACC_UPDATE:
2553 : 1 : p = "!$ACC UPDATE";
2554 : 1 : break;
2555 : 1 : case ST_OACC_WAIT:
2556 : 1 : p = "!$ACC WAIT";
2557 : 1 : break;
2558 : 1 : case ST_OACC_CACHE:
2559 : 1 : p = "!$ACC CACHE";
2560 : 1 : break;
2561 : 1 : case ST_OACC_ENTER_DATA:
2562 : 1 : p = "!$ACC ENTER DATA";
2563 : 1 : break;
2564 : 1 : case ST_OACC_EXIT_DATA:
2565 : 1 : p = "!$ACC EXIT DATA";
2566 : 1 : break;
2567 : 4 : case ST_OACC_ROUTINE:
2568 : 4 : p = "!$ACC ROUTINE";
2569 : 4 : break;
2570 : 0 : case ST_OACC_ATOMIC:
2571 : 0 : p = "!$ACC ATOMIC";
2572 : 0 : break;
2573 : 1 : case ST_OACC_END_ATOMIC:
2574 : 1 : p = "!$ACC END ATOMIC";
2575 : 1 : break;
2576 : 8 : case ST_OMP_ALLOCATE:
2577 : 8 : case ST_OMP_ALLOCATE_EXEC:
2578 : 8 : p = "!$OMP ALLOCATE";
2579 : 8 : break;
2580 : 4 : case ST_OMP_ALLOCATORS:
2581 : 4 : p = "!$OMP ALLOCATORS";
2582 : 4 : break;
2583 : 3 : case ST_OMP_ASSUME:
2584 : 3 : p = "!$OMP ASSUME";
2585 : 3 : break;
2586 : 3 : case ST_OMP_ASSUMES:
2587 : 3 : p = "!$OMP ASSUMES";
2588 : 3 : break;
2589 : 2 : case ST_OMP_ATOMIC:
2590 : 2 : p = "!$OMP ATOMIC";
2591 : 2 : break;
2592 : 1 : case ST_OMP_BARRIER:
2593 : 1 : p = "!$OMP BARRIER";
2594 : 1 : break;
2595 : 1 : case ST_OMP_CANCEL:
2596 : 1 : p = "!$OMP CANCEL";
2597 : 1 : break;
2598 : 1 : case ST_OMP_CANCELLATION_POINT:
2599 : 1 : p = "!$OMP CANCELLATION POINT";
2600 : 1 : break;
2601 : 1 : case ST_OMP_CRITICAL:
2602 : 1 : p = "!$OMP CRITICAL";
2603 : 1 : break;
2604 : 1 : case ST_OMP_DECLARE_REDUCTION:
2605 : 1 : p = "!$OMP DECLARE REDUCTION";
2606 : 1 : break;
2607 : 3 : case ST_OMP_DECLARE_SIMD:
2608 : 3 : p = "!$OMP DECLARE SIMD";
2609 : 3 : break;
2610 : 3 : case ST_OMP_DECLARE_TARGET:
2611 : 3 : p = "!$OMP DECLARE TARGET";
2612 : 3 : break;
2613 : 2 : case ST_OMP_DECLARE_VARIANT:
2614 : 2 : p = "!$OMP DECLARE VARIANT";
2615 : 2 : break;
2616 : 1 : case ST_OMP_DEPOBJ:
2617 : 1 : p = "!$OMP DEPOBJ";
2618 : 1 : break;
2619 : 0 : case ST_OMP_DISPATCH:
2620 : 0 : p = "!$OMP DISPATCH";
2621 : 0 : break;
2622 : 1 : case ST_OMP_DISTRIBUTE:
2623 : 1 : p = "!$OMP DISTRIBUTE";
2624 : 1 : break;
2625 : 1 : case ST_OMP_DISTRIBUTE_PARALLEL_DO:
2626 : 1 : p = "!$OMP DISTRIBUTE PARALLEL DO";
2627 : 1 : break;
2628 : 1 : case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2629 : 1 : p = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
2630 : 1 : break;
2631 : 1 : case ST_OMP_DISTRIBUTE_SIMD:
2632 : 1 : p = "!$OMP DISTRIBUTE SIMD";
2633 : 1 : break;
2634 : 4 : case ST_OMP_DO:
2635 : 4 : p = "!$OMP DO";
2636 : 4 : break;
2637 : 2 : case ST_OMP_DO_SIMD:
2638 : 2 : p = "!$OMP DO SIMD";
2639 : 2 : break;
2640 : 1 : case ST_OMP_END_ALLOCATORS:
2641 : 1 : p = "!$OMP END ALLOCATORS";
2642 : 1 : break;
2643 : 0 : case ST_OMP_END_ASSUME:
2644 : 0 : p = "!$OMP END ASSUME";
2645 : 0 : break;
2646 : 2 : case ST_OMP_END_ATOMIC:
2647 : 2 : p = "!$OMP END ATOMIC";
2648 : 2 : break;
2649 : 3 : case ST_OMP_END_CRITICAL:
2650 : 3 : p = "!$OMP END CRITICAL";
2651 : 3 : break;
2652 : 0 : case ST_OMP_END_DISPATCH:
2653 : 0 : p = "!$OMP END DISPATCH";
2654 : 0 : break;
2655 : 2 : case ST_OMP_END_DISTRIBUTE:
2656 : 2 : p = "!$OMP END DISTRIBUTE";
2657 : 2 : break;
2658 : 2 : case ST_OMP_END_DISTRIBUTE_PARALLEL_DO:
2659 : 2 : p = "!$OMP END DISTRIBUTE PARALLEL DO";
2660 : 2 : break;
2661 : 2 : case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD:
2662 : 2 : p = "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
2663 : 2 : break;
2664 : 2 : case ST_OMP_END_DISTRIBUTE_SIMD:
2665 : 2 : p = "!$OMP END DISTRIBUTE SIMD";
2666 : 2 : break;
2667 : 3 : case ST_OMP_END_DO:
2668 : 3 : p = "!$OMP END DO";
2669 : 3 : break;
2670 : 2 : case ST_OMP_END_DO_SIMD:
2671 : 2 : p = "!$OMP END DO SIMD";
2672 : 2 : break;
2673 : 3 : case ST_OMP_END_SCOPE:
2674 : 3 : p = "!$OMP END SCOPE";
2675 : 3 : break;
2676 : 2 : case ST_OMP_END_SIMD:
2677 : 2 : p = "!$OMP END SIMD";
2678 : 2 : break;
2679 : 2 : case ST_OMP_END_LOOP:
2680 : 2 : p = "!$OMP END LOOP";
2681 : 2 : break;
2682 : 3 : case ST_OMP_END_MASKED:
2683 : 3 : p = "!$OMP END MASKED";
2684 : 3 : break;
2685 : 2 : case ST_OMP_END_MASKED_TASKLOOP:
2686 : 2 : p = "!$OMP END MASKED TASKLOOP";
2687 : 2 : break;
2688 : 2 : case ST_OMP_END_MASKED_TASKLOOP_SIMD:
2689 : 2 : p = "!$OMP END MASKED TASKLOOP SIMD";
2690 : 2 : break;
2691 : 3 : case ST_OMP_END_MASTER:
2692 : 3 : p = "!$OMP END MASTER";
2693 : 3 : break;
2694 : 2 : case ST_OMP_END_MASTER_TASKLOOP:
2695 : 2 : p = "!$OMP END MASTER TASKLOOP";
2696 : 2 : break;
2697 : 2 : case ST_OMP_END_MASTER_TASKLOOP_SIMD:
2698 : 2 : p = "!$OMP END MASTER TASKLOOP SIMD";
2699 : 2 : break;
2700 : 3 : case ST_OMP_END_ORDERED:
2701 : 3 : p = "!$OMP END ORDERED";
2702 : 3 : break;
2703 : 13 : case ST_OMP_END_PARALLEL:
2704 : 13 : p = "!$OMP END PARALLEL";
2705 : 13 : break;
2706 : 2 : case ST_OMP_END_PARALLEL_DO:
2707 : 2 : p = "!$OMP END PARALLEL DO";
2708 : 2 : break;
2709 : 2 : case ST_OMP_END_PARALLEL_DO_SIMD:
2710 : 2 : p = "!$OMP END PARALLEL DO SIMD";
2711 : 2 : break;
2712 : 1 : case ST_OMP_END_PARALLEL_LOOP:
2713 : 1 : p = "!$OMP END PARALLEL LOOP";
2714 : 1 : break;
2715 : 3 : case ST_OMP_END_PARALLEL_MASKED:
2716 : 3 : p = "!$OMP END PARALLEL MASKED";
2717 : 3 : break;
2718 : 2 : case ST_OMP_END_PARALLEL_MASKED_TASKLOOP:
2719 : 2 : p = "!$OMP END PARALLEL MASKED TASKLOOP";
2720 : 2 : break;
2721 : 2 : case ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD:
2722 : 2 : p = "!$OMP END PARALLEL MASKED TASKLOOP SIMD";
2723 : 2 : break;
2724 : 3 : case ST_OMP_END_PARALLEL_MASTER:
2725 : 3 : p = "!$OMP END PARALLEL MASTER";
2726 : 3 : break;
2727 : 2 : case ST_OMP_END_PARALLEL_MASTER_TASKLOOP:
2728 : 2 : p = "!$OMP END PARALLEL MASTER TASKLOOP";
2729 : 2 : break;
2730 : 2 : case ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD:
2731 : 2 : p = "!$OMP END PARALLEL MASTER TASKLOOP SIMD";
2732 : 2 : break;
2733 : 2 : case ST_OMP_END_PARALLEL_SECTIONS:
2734 : 2 : p = "!$OMP END PARALLEL SECTIONS";
2735 : 2 : break;
2736 : 3 : case ST_OMP_END_PARALLEL_WORKSHARE:
2737 : 3 : p = "!$OMP END PARALLEL WORKSHARE";
2738 : 3 : break;
2739 : 2 : case ST_OMP_END_SECTIONS:
2740 : 2 : p = "!$OMP END SECTIONS";
2741 : 2 : break;
2742 : 3 : case ST_OMP_END_SINGLE:
2743 : 3 : p = "!$OMP END SINGLE";
2744 : 3 : break;
2745 : 5 : case ST_OMP_END_TASK:
2746 : 5 : p = "!$OMP END TASK";
2747 : 5 : break;
2748 : 5 : case ST_OMP_END_TARGET:
2749 : 5 : p = "!$OMP END TARGET";
2750 : 5 : break;
2751 : 3 : case ST_OMP_END_TARGET_DATA:
2752 : 3 : p = "!$OMP END TARGET DATA";
2753 : 3 : break;
2754 : 3 : case ST_OMP_END_TARGET_PARALLEL:
2755 : 3 : p = "!$OMP END TARGET PARALLEL";
2756 : 3 : break;
2757 : 2 : case ST_OMP_END_TARGET_PARALLEL_DO:
2758 : 2 : p = "!$OMP END TARGET PARALLEL DO";
2759 : 2 : break;
2760 : 2 : case ST_OMP_END_TARGET_PARALLEL_DO_SIMD:
2761 : 2 : p = "!$OMP END TARGET PARALLEL DO SIMD";
2762 : 2 : break;
2763 : 2 : case ST_OMP_END_TARGET_PARALLEL_LOOP:
2764 : 2 : p = "!$OMP END TARGET PARALLEL LOOP";
2765 : 2 : break;
2766 : 2 : case ST_OMP_END_TARGET_SIMD:
2767 : 2 : p = "!$OMP END TARGET SIMD";
2768 : 2 : break;
2769 : 3 : case ST_OMP_END_TARGET_TEAMS:
2770 : 3 : p = "!$OMP END TARGET TEAMS";
2771 : 3 : break;
2772 : 2 : case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE:
2773 : 2 : p = "!$OMP END TARGET TEAMS DISTRIBUTE";
2774 : 2 : break;
2775 : 2 : case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2776 : 2 : p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2777 : 2 : break;
2778 : 2 : case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2779 : 2 : p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2780 : 2 : break;
2781 : 2 : case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD:
2782 : 2 : p = "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2783 : 2 : break;
2784 : 2 : case ST_OMP_END_TARGET_TEAMS_LOOP:
2785 : 2 : p = "!$OMP END TARGET TEAMS LOOP";
2786 : 2 : break;
2787 : 3 : case ST_OMP_END_TASKGROUP:
2788 : 3 : p = "!$OMP END TASKGROUP";
2789 : 3 : break;
2790 : 2 : case ST_OMP_END_TASKLOOP:
2791 : 2 : p = "!$OMP END TASKLOOP";
2792 : 2 : break;
2793 : 2 : case ST_OMP_END_TASKLOOP_SIMD:
2794 : 2 : p = "!$OMP END TASKLOOP SIMD";
2795 : 2 : break;
2796 : 3 : case ST_OMP_END_TEAMS:
2797 : 3 : p = "!$OMP END TEAMS";
2798 : 3 : break;
2799 : 2 : case ST_OMP_END_TEAMS_DISTRIBUTE:
2800 : 2 : p = "!$OMP END TEAMS DISTRIBUTE";
2801 : 2 : break;
2802 : 2 : case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO:
2803 : 2 : p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2804 : 2 : break;
2805 : 2 : case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2806 : 2 : p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2807 : 2 : break;
2808 : 2 : case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD:
2809 : 2 : p = "!$OMP END TEAMS DISTRIBUTE SIMD";
2810 : 2 : break;
2811 : 1 : case ST_OMP_END_TEAMS_LOOP:
2812 : 1 : p = "!$OMP END TEAMS LOOP";
2813 : 1 : break;
2814 : 8 : case ST_OMP_END_TILE:
2815 : 8 : p = "!$OMP END TILE";
2816 : 8 : break;
2817 : 4 : case ST_OMP_END_UNROLL:
2818 : 4 : p = "!$OMP END UNROLL";
2819 : 4 : break;
2820 : 3 : case ST_OMP_END_WORKSHARE:
2821 : 3 : p = "!$OMP END WORKSHARE";
2822 : 3 : break;
2823 : 3 : case ST_OMP_ERROR:
2824 : 3 : p = "!$OMP ERROR";
2825 : 3 : break;
2826 : 1 : case ST_OMP_FLUSH:
2827 : 1 : p = "!$OMP FLUSH";
2828 : 1 : break;
2829 : 0 : case ST_OMP_INTEROP:
2830 : 0 : p = "!$OMP INTEROP";
2831 : 0 : break;
2832 : 0 : case ST_OMP_LOOP:
2833 : 0 : p = "!$OMP LOOP";
2834 : 0 : break;
2835 : 0 : case ST_OMP_MASKED:
2836 : 0 : p = "!$OMP MASKED";
2837 : 0 : break;
2838 : 0 : case ST_OMP_MASKED_TASKLOOP:
2839 : 0 : p = "!$OMP MASKED TASKLOOP";
2840 : 0 : break;
2841 : 0 : case ST_OMP_MASKED_TASKLOOP_SIMD:
2842 : 0 : p = "!$OMP MASKED TASKLOOP SIMD";
2843 : 0 : break;
2844 : 1 : case ST_OMP_MASTER:
2845 : 1 : p = "!$OMP MASTER";
2846 : 1 : break;
2847 : 0 : case ST_OMP_MASTER_TASKLOOP:
2848 : 0 : p = "!$OMP MASTER TASKLOOP";
2849 : 0 : break;
2850 : 0 : case ST_OMP_MASTER_TASKLOOP_SIMD:
2851 : 0 : p = "!$OMP MASTER TASKLOOP SIMD";
2852 : 0 : break;
2853 : 1 : case ST_OMP_ORDERED:
2854 : 1 : case ST_OMP_ORDERED_DEPEND:
2855 : 1 : p = "!$OMP ORDERED";
2856 : 1 : break;
2857 : 0 : case ST_OMP_NOTHING:
2858 : : /* Note: gfc_match_omp_nothing returns ST_NONE. */
2859 : 0 : p = "!$OMP NOTHING";
2860 : 0 : break;
2861 : 9 : case ST_OMP_PARALLEL:
2862 : 9 : p = "!$OMP PARALLEL";
2863 : 9 : break;
2864 : 6 : case ST_OMP_PARALLEL_DO:
2865 : 6 : p = "!$OMP PARALLEL DO";
2866 : 6 : break;
2867 : 0 : case ST_OMP_PARALLEL_LOOP:
2868 : 0 : p = "!$OMP PARALLEL LOOP";
2869 : 0 : break;
2870 : 1 : case ST_OMP_PARALLEL_DO_SIMD:
2871 : 1 : p = "!$OMP PARALLEL DO SIMD";
2872 : 1 : break;
2873 : 0 : case ST_OMP_PARALLEL_MASKED:
2874 : 0 : p = "!$OMP PARALLEL MASKED";
2875 : 0 : break;
2876 : 0 : case ST_OMP_PARALLEL_MASKED_TASKLOOP:
2877 : 0 : p = "!$OMP PARALLEL MASKED TASKLOOP";
2878 : 0 : break;
2879 : 0 : case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
2880 : 0 : p = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
2881 : 0 : break;
2882 : 0 : case ST_OMP_PARALLEL_MASTER:
2883 : 0 : p = "!$OMP PARALLEL MASTER";
2884 : 0 : break;
2885 : 0 : case ST_OMP_PARALLEL_MASTER_TASKLOOP:
2886 : 0 : p = "!$OMP PARALLEL MASTER TASKLOOP";
2887 : 0 : break;
2888 : 0 : case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
2889 : 0 : p = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
2890 : 0 : break;
2891 : 1 : case ST_OMP_PARALLEL_SECTIONS:
2892 : 1 : p = "!$OMP PARALLEL SECTIONS";
2893 : 1 : break;
2894 : 1 : case ST_OMP_PARALLEL_WORKSHARE:
2895 : 1 : p = "!$OMP PARALLEL WORKSHARE";
2896 : 1 : break;
2897 : 2 : case ST_OMP_REQUIRES:
2898 : 2 : p = "!$OMP REQUIRES";
2899 : 2 : break;
2900 : 0 : case ST_OMP_SCAN:
2901 : 0 : p = "!$OMP SCAN";
2902 : 0 : break;
2903 : 1 : case ST_OMP_SCOPE:
2904 : 1 : p = "!$OMP SCOPE";
2905 : 1 : break;
2906 : 2 : case ST_OMP_SECTIONS:
2907 : 2 : p = "!$OMP SECTIONS";
2908 : 2 : break;
2909 : 1 : case ST_OMP_SECTION:
2910 : 1 : p = "!$OMP SECTION";
2911 : 1 : break;
2912 : 3 : case ST_OMP_SIMD:
2913 : 3 : p = "!$OMP SIMD";
2914 : 3 : break;
2915 : 2 : case ST_OMP_SINGLE:
2916 : 2 : p = "!$OMP SINGLE";
2917 : 2 : break;
2918 : 4 : case ST_OMP_TARGET:
2919 : 4 : p = "!$OMP TARGET";
2920 : 4 : break;
2921 : 1 : case ST_OMP_TARGET_DATA:
2922 : 1 : p = "!$OMP TARGET DATA";
2923 : 1 : break;
2924 : 1 : case ST_OMP_TARGET_ENTER_DATA:
2925 : 1 : p = "!$OMP TARGET ENTER DATA";
2926 : 1 : break;
2927 : 1 : case ST_OMP_TARGET_EXIT_DATA:
2928 : 1 : p = "!$OMP TARGET EXIT DATA";
2929 : 1 : break;
2930 : 2 : case ST_OMP_TARGET_PARALLEL:
2931 : 2 : p = "!$OMP TARGET PARALLEL";
2932 : 2 : break;
2933 : 2 : case ST_OMP_TARGET_PARALLEL_DO:
2934 : 2 : p = "!$OMP TARGET PARALLEL DO";
2935 : 2 : break;
2936 : 2 : case ST_OMP_TARGET_PARALLEL_DO_SIMD:
2937 : 2 : p = "!$OMP TARGET PARALLEL DO SIMD";
2938 : 2 : break;
2939 : 1 : case ST_OMP_TARGET_PARALLEL_LOOP:
2940 : 1 : p = "!$OMP TARGET PARALLEL LOOP";
2941 : 1 : break;
2942 : 2 : case ST_OMP_TARGET_SIMD:
2943 : 2 : p = "!$OMP TARGET SIMD";
2944 : 2 : break;
2945 : 2 : case ST_OMP_TARGET_TEAMS:
2946 : 2 : p = "!$OMP TARGET TEAMS";
2947 : 2 : break;
2948 : 2 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
2949 : 2 : p = "!$OMP TARGET TEAMS DISTRIBUTE";
2950 : 2 : break;
2951 : 2 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2952 : 2 : p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2953 : 2 : break;
2954 : 2 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2955 : 2 : p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2956 : 2 : break;
2957 : 2 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2958 : 2 : p = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2959 : 2 : break;
2960 : 1 : case ST_OMP_TARGET_TEAMS_LOOP:
2961 : 1 : p = "!$OMP TARGET TEAMS LOOP";
2962 : 1 : break;
2963 : 1 : case ST_OMP_TARGET_UPDATE:
2964 : 1 : p = "!$OMP TARGET UPDATE";
2965 : 1 : break;
2966 : 1 : case ST_OMP_TASK:
2967 : 1 : p = "!$OMP TASK";
2968 : 1 : break;
2969 : 1 : case ST_OMP_TASKGROUP:
2970 : 1 : p = "!$OMP TASKGROUP";
2971 : 1 : break;
2972 : 1 : case ST_OMP_TASKLOOP:
2973 : 1 : p = "!$OMP TASKLOOP";
2974 : 1 : break;
2975 : 1 : case ST_OMP_TASKLOOP_SIMD:
2976 : 1 : p = "!$OMP TASKLOOP SIMD";
2977 : 1 : break;
2978 : 1 : case ST_OMP_TASKWAIT:
2979 : 1 : p = "!$OMP TASKWAIT";
2980 : 1 : break;
2981 : 1 : case ST_OMP_TASKYIELD:
2982 : 1 : p = "!$OMP TASKYIELD";
2983 : 1 : break;
2984 : 1 : case ST_OMP_TEAMS:
2985 : 1 : p = "!$OMP TEAMS";
2986 : 1 : break;
2987 : 1 : case ST_OMP_TEAMS_DISTRIBUTE:
2988 : 1 : p = "!$OMP TEAMS DISTRIBUTE";
2989 : 1 : break;
2990 : 1 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2991 : 1 : p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2992 : 1 : break;
2993 : 1 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2994 : 1 : p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2995 : 1 : break;
2996 : 1 : case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
2997 : 1 : p = "!$OMP TEAMS DISTRIBUTE SIMD";
2998 : 1 : break;
2999 : 0 : case ST_OMP_TEAMS_LOOP:
3000 : 0 : p = "!$OMP TEAMS LOOP";
3001 : 0 : break;
3002 : 1 : case ST_OMP_THREADPRIVATE:
3003 : 1 : p = "!$OMP THREADPRIVATE";
3004 : 1 : break;
3005 : 0 : case ST_OMP_TILE:
3006 : 0 : p = "!$OMP TILE";
3007 : 0 : break;
3008 : 0 : case ST_OMP_UNROLL:
3009 : 0 : p = "!$OMP UNROLL";
3010 : 0 : break;
3011 : 2 : case ST_OMP_WORKSHARE:
3012 : 2 : p = "!$OMP WORKSHARE";
3013 : 2 : break;
3014 : 0 : default:
3015 : 0 : gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
3016 : : }
3017 : :
3018 : 26743 : if (strip_sentinel && p[0] == '!')
3019 : 9 : return p + strlen ("!$OMP ");
3020 : : return p;
3021 : : }
3022 : :
3023 : :
3024 : : /* Create a symbol for the main program and assign it to ns->proc_name. */
3025 : :
3026 : : static void
3027 : 26793 : main_program_symbol (gfc_namespace *ns, const char *name)
3028 : : {
3029 : 26793 : gfc_symbol *main_program;
3030 : 26793 : symbol_attribute attr;
3031 : :
3032 : 26793 : gfc_get_symbol (name, ns, &main_program);
3033 : 26793 : gfc_clear_attr (&attr);
3034 : 26793 : attr.flavor = FL_PROGRAM;
3035 : 26793 : attr.proc = PROC_UNKNOWN;
3036 : 26793 : attr.subroutine = 1;
3037 : 26793 : attr.access = ACCESS_PUBLIC;
3038 : 26793 : attr.is_main_program = 1;
3039 : 26793 : main_program->attr = attr;
3040 : 26793 : main_program->declared_at = gfc_current_locus;
3041 : 26793 : ns->proc_name = main_program;
3042 : 26793 : gfc_commit_symbols ();
3043 : 26793 : }
3044 : :
3045 : :
3046 : : /* Do whatever is necessary to accept the last statement. */
3047 : :
3048 : : static void
3049 : 1202314 : accept_statement (gfc_statement st)
3050 : : {
3051 : 1202314 : switch (st)
3052 : : {
3053 : : case ST_IMPLICIT_NONE:
3054 : : case ST_IMPLICIT:
3055 : : break;
3056 : :
3057 : 67841 : case ST_FUNCTION:
3058 : 67841 : case ST_SUBROUTINE:
3059 : 67841 : case ST_MODULE:
3060 : 67841 : case ST_SUBMODULE:
3061 : 67841 : gfc_current_ns->proc_name = gfc_new_block;
3062 : 67841 : break;
3063 : :
3064 : : /* If the statement is the end of a block, lay down a special code
3065 : : that allows a branch to the end of the block from within the
3066 : : construct. IF and SELECT are treated differently from DO
3067 : : (where EXEC_NOP is added inside the loop) for two
3068 : : reasons:
3069 : : 1. END DO has a meaning in the sense that after a GOTO to
3070 : : it, the loop counter must be increased.
3071 : : 2. IF blocks and SELECT blocks can consist of multiple
3072 : : parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
3073 : : Putting the label before the END IF would make the jump
3074 : : from, say, the ELSE IF block to the END IF illegal. */
3075 : :
3076 : 18513 : case ST_ENDIF:
3077 : 18513 : case ST_END_SELECT:
3078 : 18513 : case ST_END_CRITICAL:
3079 : 18513 : if (gfc_statement_label != NULL)
3080 : : {
3081 : 43 : new_st.op = EXEC_END_NESTED_BLOCK;
3082 : 43 : add_statement ();
3083 : : }
3084 : : break;
3085 : :
3086 : : /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
3087 : : one parallel block. Thus, we add the special code to the nested block
3088 : : itself, instead of the parent one. */
3089 : 2488 : case ST_END_BLOCK:
3090 : 2488 : case ST_END_ASSOCIATE:
3091 : 2488 : if (gfc_statement_label != NULL)
3092 : : {
3093 : 2 : new_st.op = EXEC_END_BLOCK;
3094 : 2 : add_statement ();
3095 : : }
3096 : : break;
3097 : :
3098 : : /* The end-of-program unit statements do not get the special
3099 : : marker and require a statement of some sort if they are a
3100 : : branch target. */
3101 : :
3102 : 72534 : case ST_END_PROGRAM:
3103 : 72534 : case ST_END_FUNCTION:
3104 : 72534 : case ST_END_SUBROUTINE:
3105 : 72534 : if (gfc_statement_label != NULL)
3106 : : {
3107 : 20 : new_st.op = EXEC_RETURN;
3108 : 20 : add_statement ();
3109 : : }
3110 : : else
3111 : : {
3112 : 72514 : new_st.op = EXEC_END_PROCEDURE;
3113 : 72514 : add_statement ();
3114 : : }
3115 : :
3116 : : break;
3117 : :
3118 : 618861 : case ST_ENTRY:
3119 : 618861 : case_executable:
3120 : 618861 : case_exec_markers:
3121 : 618861 : add_statement ();
3122 : 618861 : break;
3123 : :
3124 : : default:
3125 : : break;
3126 : : }
3127 : :
3128 : 1202314 : gfc_commit_symbols ();
3129 : 1202314 : gfc_warning_check ();
3130 : 1202314 : gfc_clear_new_st ();
3131 : 1202314 : }
3132 : :
3133 : :
3134 : : /* Undo anything tentative that has been built for the current statement,
3135 : : except if a gfc_charlen structure has been added to current namespace's
3136 : : list of gfc_charlen structure. */
3137 : :
3138 : : static void
3139 : 7975076 : reject_statement (void)
3140 : : {
3141 : 7975076 : gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv);
3142 : 7975076 : gfc_current_ns->equiv = gfc_current_ns->old_equiv;
3143 : 7975076 : gfc_drop_interface_elements_before (current_interface_ptr,
3144 : : previous_interface_head);
3145 : :
3146 : 7975076 : gfc_reject_data (gfc_current_ns);
3147 : :
3148 : : /* Don't queue use-association of a module if we reject the use statement. */
3149 : 7975076 : gfc_restore_old_module_list ();
3150 : :
3151 : 7975076 : gfc_new_block = NULL;
3152 : 7975076 : gfc_undo_symbols ();
3153 : 7975076 : gfc_clear_warning ();
3154 : 7975076 : undo_new_statement ();
3155 : 7975076 : }
3156 : :
3157 : :
3158 : : /* Generic complaint about an out of order statement. We also do
3159 : : whatever is necessary to clean up. */
3160 : :
3161 : : static void
3162 : 266 : unexpected_statement (gfc_statement st)
3163 : : {
3164 : 266 : gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
3165 : :
3166 : 266 : reject_statement ();
3167 : 266 : }
3168 : :
3169 : :
3170 : : /* Given the next statement seen by the matcher, make sure that it is
3171 : : in proper order with the last. This subroutine is initialized by
3172 : : calling it with an argument of ST_NONE. If there is a problem, we
3173 : : issue an error and return false. Otherwise we return true.
3174 : :
3175 : : Individual parsers need to verify that the statements seen are
3176 : : valid before calling here, i.e., ENTRY statements are not allowed in
3177 : : INTERFACE blocks. The following diagram is taken from the standard:
3178 : :
3179 : : +---------------------------------------+
3180 : : | program subroutine function module |
3181 : : +---------------------------------------+
3182 : : | use |
3183 : : +---------------------------------------+
3184 : : | import |
3185 : : +---------------------------------------+
3186 : : | | implicit none |
3187 : : | +-----------+------------------+
3188 : : | | parameter | implicit |
3189 : : | +-----------+------------------+
3190 : : | format | | derived type |
3191 : : | entry | parameter | interface |
3192 : : | | data | specification |
3193 : : | | | statement func |
3194 : : | +-----------+------------------+
3195 : : | | data | executable |
3196 : : +--------+-----------+------------------+
3197 : : | contains |
3198 : : +---------------------------------------+
3199 : : | internal module/subprogram |
3200 : : +---------------------------------------+
3201 : : | end |
3202 : : +---------------------------------------+
3203 : :
3204 : : */
3205 : :
3206 : : enum state_order
3207 : : {
3208 : : ORDER_START,
3209 : : ORDER_USE,
3210 : : ORDER_IMPORT,
3211 : : ORDER_IMPLICIT_NONE,
3212 : : ORDER_IMPLICIT,
3213 : : ORDER_SPEC,
3214 : : ORDER_EXEC
3215 : : };
3216 : :
3217 : : typedef struct
3218 : : {
3219 : : enum state_order state;
3220 : : gfc_statement last_statement;
3221 : : locus where;
3222 : : }
3223 : : st_state;
3224 : :
3225 : : static bool
3226 : 415718 : verify_st_order (st_state *p, gfc_statement st, bool silent)
3227 : : {
3228 : :
3229 : 415718 : switch (st)
3230 : : {
3231 : 108020 : case ST_NONE:
3232 : 108020 : p->state = ORDER_START;
3233 : 108020 : in_exec_part = false;
3234 : 108020 : break;
3235 : :
3236 : 23035 : case ST_USE:
3237 : 23035 : if (p->state > ORDER_USE)
3238 : 0 : goto order;
3239 : 23035 : p->state = ORDER_USE;
3240 : 23035 : break;
3241 : :
3242 : 3495 : case ST_IMPORT:
3243 : 3495 : if (p->state > ORDER_IMPORT)
3244 : 0 : goto order;
3245 : 3495 : p->state = ORDER_IMPORT;
3246 : 3495 : break;
3247 : :
3248 : 22948 : case ST_IMPLICIT_NONE:
3249 : 22948 : if (p->state > ORDER_IMPLICIT)
3250 : 0 : goto order;
3251 : :
3252 : : /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
3253 : : statement disqualifies a USE but not an IMPLICIT NONE.
3254 : : Duplicate IMPLICIT NONEs are caught when the implicit types
3255 : : are set. */
3256 : :
3257 : 22948 : p->state = ORDER_IMPLICIT_NONE;
3258 : 22948 : break;
3259 : :
3260 : 12543 : case ST_IMPLICIT:
3261 : 12543 : if (p->state > ORDER_IMPLICIT)
3262 : 9582 : goto order;
3263 : 2961 : p->state = ORDER_IMPLICIT;
3264 : 2961 : break;
3265 : :
3266 : 490 : case ST_FORMAT:
3267 : 490 : case ST_ENTRY:
3268 : 490 : if (p->state < ORDER_IMPLICIT_NONE)
3269 : 77 : p->state = ORDER_IMPLICIT_NONE;
3270 : : break;
3271 : :
3272 : 6765 : case ST_PARAMETER:
3273 : 6765 : if (p->state >= ORDER_EXEC)
3274 : 0 : goto order;
3275 : 6765 : if (p->state < ORDER_IMPLICIT)
3276 : 79 : p->state = ORDER_IMPLICIT;
3277 : : break;
3278 : :
3279 : 2424 : case ST_DATA:
3280 : 2424 : if (p->state < ORDER_SPEC)
3281 : 17 : p->state = ORDER_SPEC;
3282 : : break;
3283 : :
3284 : 232595 : case ST_PUBLIC:
3285 : 232595 : case ST_PRIVATE:
3286 : 232595 : case ST_STRUCTURE_DECL:
3287 : 232595 : case ST_DERIVED_DECL:
3288 : 232595 : case_decl:
3289 : 232595 : if (p->state >= ORDER_EXEC)
3290 : 0 : goto order;
3291 : 232595 : if (p->state < ORDER_SPEC)
3292 : 92654 : p->state = ORDER_SPEC;
3293 : : break;
3294 : :
3295 : 2684 : case_omp_decl:
3296 : : /* The OpenMP/OpenACC directives have to be somewhere in the specification
3297 : : part, but there are no further requirements on their ordering.
3298 : : Thus don't adjust p->state, just ignore them. */
3299 : 2684 : if (p->state >= ORDER_EXEC)
3300 : 0 : goto order;
3301 : : break;
3302 : :
3303 : 715 : case_executable:
3304 : 715 : case_exec_markers:
3305 : 715 : if (p->state < ORDER_EXEC)
3306 : 715 : p->state = ORDER_EXEC;
3307 : 715 : in_exec_part = true;
3308 : 715 : break;
3309 : :
3310 : : default:
3311 : : return false;
3312 : : }
3313 : :
3314 : : /* All is well, record the statement in case we need it next time. */
3315 : 406132 : p->where = gfc_current_locus;
3316 : 406132 : p->last_statement = st;
3317 : 406132 : return true;
3318 : :
3319 : 9582 : order:
3320 : 9582 : if (!silent)
3321 : 1 : gfc_error ("%s statement at %C cannot follow %s statement at %L",
3322 : : gfc_ascii_statement (st),
3323 : : gfc_ascii_statement (p->last_statement), &p->where);
3324 : :
3325 : : return false;
3326 : : }
3327 : :
3328 : :
3329 : : /* Handle an unexpected end of file. This is a show-stopper... */
3330 : :
3331 : : static void unexpected_eof (void) ATTRIBUTE_NORETURN;
3332 : :
3333 : : static void
3334 : 31 : unexpected_eof (void)
3335 : : {
3336 : 31 : gfc_state_data *p;
3337 : :
3338 : 31 : gfc_error ("Unexpected end of file in %qs", gfc_source_file);
3339 : :
3340 : : /* Memory cleanup. Move to "second to last". */
3341 : 66 : for (p = gfc_state_stack; p && p->previous && p->previous->previous;
3342 : : p = p->previous);
3343 : :
3344 : 31 : gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
3345 : 31 : gfc_done_2 ();
3346 : :
3347 : 31 : longjmp (eof_buf, 1);
3348 : :
3349 : : /* Avoids build error on systems where longjmp is not declared noreturn. */
3350 : : gcc_unreachable ();
3351 : : }
3352 : :
3353 : :
3354 : : /* Parse the CONTAINS section of a derived type definition. */
3355 : :
3356 : : gfc_access gfc_typebound_default_access;
3357 : :
3358 : : static bool
3359 : 2099 : parse_derived_contains (void)
3360 : : {
3361 : 2099 : gfc_state_data s;
3362 : 2099 : bool seen_private = false;
3363 : 2099 : bool seen_comps = false;
3364 : 2099 : bool error_flag = false;
3365 : 2099 : bool to_finish;
3366 : :
3367 : 2099 : gcc_assert (gfc_current_state () == COMP_DERIVED);
3368 : 2099 : gcc_assert (gfc_current_block ());
3369 : :
3370 : : /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
3371 : : section. */
3372 : 2099 : if (gfc_current_block ()->attr.sequence)
3373 : 1 : gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
3374 : : " section at %C", gfc_current_block ()->name);
3375 : 2099 : if (gfc_current_block ()->attr.is_bind_c)
3376 : 1 : gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
3377 : : " section at %C", gfc_current_block ()->name);
3378 : :
3379 : 2099 : accept_statement (ST_CONTAINS);
3380 : 2099 : push_state (&s, COMP_DERIVED_CONTAINS, NULL);
3381 : :
3382 : 2099 : gfc_typebound_default_access = ACCESS_PUBLIC;
3383 : :
3384 : 2099 : to_finish = false;
3385 : 2099 : while (!to_finish)
3386 : : {
3387 : 6374 : gfc_statement st;
3388 : 6374 : st = next_statement ();
3389 : 6374 : switch (st)
3390 : : {
3391 : 0 : case ST_NONE:
3392 : 0 : unexpected_eof ();
3393 : 1 : break;
3394 : :
3395 : 1 : case ST_DATA_DECL:
3396 : 1 : gfc_error ("Components in TYPE at %C must precede CONTAINS");
3397 : 1 : goto error;
3398 : :
3399 : 3007 : case ST_PROCEDURE:
3400 : 3007 : if (!gfc_notify_std (GFC_STD_F2003, "Type-bound procedure at %C"))
3401 : 0 : goto error;
3402 : :
3403 : 3007 : accept_statement (ST_PROCEDURE);
3404 : 3007 : seen_comps = true;
3405 : 3007 : break;
3406 : :
3407 : 857 : case ST_GENERIC:
3408 : 857 : if (!gfc_notify_std (GFC_STD_F2003, "GENERIC binding at %C"))
3409 : 0 : goto error;
3410 : :
3411 : 857 : accept_statement (ST_GENERIC);
3412 : 857 : seen_comps = true;
3413 : 857 : break;
3414 : :
3415 : 377 : case ST_FINAL:
3416 : 377 : if (!gfc_notify_std (GFC_STD_F2003, "FINAL procedure declaration"
3417 : : " at %C"))
3418 : 1 : goto error;
3419 : :
3420 : 376 : accept_statement (ST_FINAL);
3421 : 376 : seen_comps = true;
3422 : 376 : break;
3423 : :
3424 : 2099 : case ST_END_TYPE:
3425 : 2099 : to_finish = true;
3426 : :
3427 : 2099 : if (!seen_comps
3428 : 2099 : && (!gfc_notify_std(GFC_STD_F2008, "Derived type definition "
3429 : : "at %C with empty CONTAINS section")))
3430 : 4 : goto error;
3431 : :
3432 : : /* ST_END_TYPE is accepted by parse_derived after return. */
3433 : : break;
3434 : :
3435 : 32 : case ST_PRIVATE:
3436 : 32 : if (!gfc_find_state (COMP_MODULE))
3437 : : {
3438 : 0 : gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3439 : : "a MODULE");
3440 : 0 : goto error;
3441 : : }
3442 : :
3443 : 32 : if (seen_comps)
3444 : : {
3445 : 1 : gfc_error ("PRIVATE statement at %C must precede procedure"
3446 : : " bindings");
3447 : 1 : goto error;
3448 : : }
3449 : :
3450 : 31 : if (seen_private)
3451 : : {
3452 : 0 : gfc_error ("Duplicate PRIVATE statement at %C");
3453 : 0 : goto error;
3454 : : }
3455 : :
3456 : 31 : accept_statement (ST_PRIVATE);
3457 : 31 : gfc_typebound_default_access = ACCESS_PRIVATE;
3458 : 31 : seen_private = true;
3459 : 31 : break;
3460 : :
3461 : 0 : case ST_SEQUENCE:
3462 : 0 : gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
3463 : 0 : goto error;
3464 : :
3465 : 1 : case ST_CONTAINS:
3466 : 1 : gfc_error ("Already inside a CONTAINS block at %C");
3467 : 1 : goto error;
3468 : :
3469 : 0 : default:
3470 : 0 : unexpected_statement (st);
3471 : 0 : break;
3472 : : }
3473 : :
3474 : 6366 : continue;
3475 : :
3476 : 8 : error:
3477 : 8 : error_flag = true;
3478 : 8 : reject_statement ();
3479 : 6366 : }
3480 : :
3481 : 2099 : pop_state ();
3482 : 2099 : gcc_assert (gfc_current_state () == COMP_DERIVED);
3483 : :
3484 : 2099 : return error_flag;
3485 : : }
3486 : :
3487 : :
3488 : : /* Set attributes for the parent symbol based on the attributes of a component
3489 : : and raise errors if conflicting attributes are found for the component. */
3490 : :
3491 : : static void
3492 : 18509 : check_component (gfc_symbol *sym, gfc_component *c, gfc_component **lockp,
3493 : : gfc_component **eventp)
3494 : : {
3495 : 18509 : bool coarray, lock_type, event_type, allocatable, pointer;
3496 : 18509 : coarray = lock_type = event_type = allocatable = pointer = false;
3497 : 18509 : gfc_component *lock_comp = NULL, *event_comp = NULL;
3498 : :
3499 : 18509 : if (lockp) lock_comp = *lockp;
3500 : 18509 : if (eventp) event_comp = *eventp;
3501 : :
3502 : : /* Look for allocatable components. */
3503 : 18509 : if (c->attr.allocatable
3504 : 15959 : || (c->ts.type == BT_CLASS && c->attr.class_ok
3505 : 769 : && CLASS_DATA (c)->attr.allocatable)
3506 : 15467 : || (c->ts.type == BT_DERIVED && !c->attr.pointer
3507 : 2837 : && c->ts.u.derived->attr.alloc_comp))
3508 : : {
3509 : 3483 : allocatable = true;
3510 : 3483 : sym->attr.alloc_comp = 1;
3511 : : }
3512 : :
3513 : : /* Look for pointer components. */
3514 : 18509 : if (c->attr.pointer
3515 : 17298 : || (c->ts.type == BT_CLASS && c->attr.class_ok
3516 : 769 : && CLASS_DATA (c)->attr.class_pointer)
3517 : 17021 : || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
3518 : : {
3519 : 1706 : pointer = true;
3520 : 1706 : sym->attr.pointer_comp = 1;
3521 : : }
3522 : :
3523 : : /* Look for procedure pointer components. */
3524 : 18509 : if (c->attr.proc_pointer
3525 : 18115 : || (c->ts.type == BT_DERIVED
3526 : 3901 : && c->ts.u.derived->attr.proc_pointer_comp))
3527 : 478 : sym->attr.proc_pointer_comp = 1;
3528 : :
3529 : : /* Looking for coarray components. */
3530 : 18509 : if (c->attr.codimension
3531 : 18438 : || (c->ts.type == BT_CLASS && c->attr.class_ok
3532 : 769 : && CLASS_DATA (c)->attr.codimension))
3533 : : {
3534 : 93 : coarray = true;
3535 : 93 : sym->attr.coarray_comp = 1;
3536 : : }
3537 : :
3538 : 18509 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
3539 : 10 : && !c->attr.pointer)
3540 : : {
3541 : 9 : coarray = true;
3542 : 9 : sym->attr.coarray_comp = 1;
3543 : : }
3544 : :
3545 : : /* Looking for lock_type components. */
3546 : 18509 : if ((c->ts.type == BT_DERIVED
3547 : 3908 : && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
3548 : 3908 : && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
3549 : 18490 : || (c->ts.type == BT_CLASS && c->attr.class_ok
3550 : 769 : && CLASS_DATA (c)->ts.u.derived->from_intmod
3551 : : == INTMOD_ISO_FORTRAN_ENV
3552 : 769 : && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
3553 : : == ISOFORTRAN_LOCK_TYPE)
3554 : 18490 : || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp
3555 : 6 : && !allocatable && !pointer))
3556 : : {
3557 : 22 : lock_type = 1;
3558 : 22 : lock_comp = c;
3559 : 22 : sym->attr.lock_comp = 1;
3560 : : }
3561 : :
3562 : : /* Looking for event_type components. */
3563 : 18509 : if ((c->ts.type == BT_DERIVED
3564 : 3908 : && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
3565 : 3908 : && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
3566 : 18509 : || (c->ts.type == BT_CLASS && c->attr.class_ok
3567 : 769 : && CLASS_DATA (c)->ts.u.derived->from_intmod
3568 : : == INTMOD_ISO_FORTRAN_ENV
3569 : 769 : && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
3570 : : == ISOFORTRAN_EVENT_TYPE)
3571 : 18509 : || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp
3572 : 0 : && !allocatable && !pointer))
3573 : : {
3574 : 0 : event_type = 1;
3575 : 0 : event_comp = c;
3576 : 0 : sym->attr.event_comp = 1;
3577 : : }
3578 : :
3579 : : /* Check for F2008, C1302 - and recall that pointers may not be coarrays
3580 : : (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
3581 : : unless there are nondirect [allocatable or pointer] components
3582 : : involved (cf. 1.3.33.1 and 1.3.33.3). */
3583 : :
3584 : 18509 : if (pointer && !coarray && lock_type)
3585 : 1 : gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
3586 : : "codimension or be a subcomponent of a coarray, "
3587 : : "which is not possible as the component has the "
3588 : : "pointer attribute", c->name, &c->loc);
3589 : 18508 : else if (pointer && !coarray && c->ts.type == BT_DERIVED
3590 : 694 : && c->ts.u.derived->attr.lock_comp)
3591 : 2 : gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3592 : : "of type LOCK_TYPE, which must have a codimension or be a "
3593 : : "subcomponent of a coarray", c->name, &c->loc);
3594 : :
3595 : 18509 : if (lock_type && allocatable && !coarray)
3596 : 3 : gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
3597 : : "a codimension", c->name, &c->loc);
3598 : 18506 : else if (lock_type && allocatable && c->ts.type == BT_DERIVED
3599 : 5 : && c->ts.u.derived->attr.lock_comp)
3600 : 0 : gfc_error ("Allocatable component %s at %L must have a codimension as "
3601 : : "it has a noncoarray subcomponent of type LOCK_TYPE",
3602 : : c->name, &c->loc);
3603 : :
3604 : 18509 : if (sym->attr.coarray_comp && !coarray && lock_type)
3605 : 1 : gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3606 : : "subcomponent of type LOCK_TYPE must have a codimension or "
3607 : : "be a subcomponent of a coarray. (Variables of type %s may "
3608 : : "not have a codimension as already a coarray "
3609 : : "subcomponent exists)", c->name, &c->loc, sym->name);
3610 : :
3611 : 18509 : if (sym->attr.lock_comp && coarray && !lock_type)
3612 : 1 : gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3613 : : "subcomponent of type LOCK_TYPE must have a codimension or "
3614 : : "be a subcomponent of a coarray. (Variables of type %s may "
3615 : : "not have a codimension as %s at %L has a codimension or a "
3616 : : "coarray subcomponent)", lock_comp->name, &lock_comp->loc,
3617 : : sym->name, c->name, &c->loc);
3618 : :
3619 : : /* Similarly for EVENT TYPE. */
3620 : :
3621 : 18509 : if (pointer && !coarray && event_type)
3622 : 0 : gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
3623 : : "codimension or be a subcomponent of a coarray, "
3624 : : "which is not possible as the component has the "
3625 : : "pointer attribute", c->name, &c->loc);
3626 : 18509 : else if (pointer && !coarray && c->ts.type == BT_DERIVED
3627 : 695 : && c->ts.u.derived->attr.event_comp)
3628 : 0 : gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3629 : : "of type EVENT_TYPE, which must have a codimension or be a "
3630 : : "subcomponent of a coarray", c->name, &c->loc);
3631 : :
3632 : 18509 : if (event_type && allocatable && !coarray)
3633 : 0 : gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
3634 : : "a codimension", c->name, &c->loc);
3635 : 18509 : else if (event_type && allocatable && c->ts.type == BT_DERIVED
3636 : 0 : && c->ts.u.derived->attr.event_comp)
3637 : 0 : gfc_error ("Allocatable component %s at %L must have a codimension as "
3638 : : "it has a noncoarray subcomponent of type EVENT_TYPE",
3639 : : c->name, &c->loc);
3640 : :
3641 : 18509 : if (sym->attr.coarray_comp && !coarray && event_type)
3642 : 0 : gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3643 : : "subcomponent of type EVENT_TYPE must have a codimension or "
3644 : : "be a subcomponent of a coarray. (Variables of type %s may "
3645 : : "not have a codimension as already a coarray "
3646 : : "subcomponent exists)", c->name, &c->loc, sym->name);
3647 : :
3648 : 18509 : if (sym->attr.event_comp && coarray && !event_type)
3649 : 0 : gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3650 : : "subcomponent of type EVENT_TYPE must have a codimension or "
3651 : : "be a subcomponent of a coarray. (Variables of type %s may "
3652 : : "not have a codimension as %s at %L has a codimension or a "
3653 : : "coarray subcomponent)", event_comp->name, &event_comp->loc,
3654 : : sym->name, c->name, &c->loc);
3655 : :
3656 : : /* Look for private components. */
3657 : 18509 : if (sym->component_access == ACCESS_PRIVATE
3658 : 18041 : || c->attr.access == ACCESS_PRIVATE
3659 : 17910 : || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
3660 : 885 : sym->attr.private_comp = 1;
3661 : :
3662 : 18509 : if (lockp) *lockp = lock_comp;
3663 : 18509 : if (eventp) *eventp = event_comp;
3664 : 18509 : }
3665 : :
3666 : :
3667 : : static void parse_struct_map (gfc_statement);
3668 : :
3669 : : /* Parse a union component definition within a structure definition. */
3670 : :
3671 : : static void
3672 : 132 : parse_union (void)
3673 : : {
3674 : 132 : int compiling;
3675 : 132 : gfc_statement st;
3676 : 132 : gfc_state_data s;
3677 : 132 : gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
3678 : 132 : gfc_symbol *un;
3679 : :
3680 : 132 : accept_statement(ST_UNION);
3681 : 132 : push_state (&s, COMP_UNION, gfc_new_block);
3682 : 132 : un = gfc_new_block;
3683 : :
3684 : 132 : compiling = 1;
3685 : :
3686 : 132 : while (compiling)
3687 : : {
3688 : 391 : st = next_statement ();
3689 : : /* Only MAP declarations valid within a union. */
3690 : 391 : switch (st)
3691 : : {
3692 : 0 : case ST_NONE:
3693 : 0 : unexpected_eof ();
3694 : :
3695 : 257 : case ST_MAP:
3696 : 257 : accept_statement (ST_MAP);
3697 : 257 : parse_struct_map (ST_MAP);
3698 : : /* Add a component to the union for each map. */
3699 : 257 : if (!gfc_add_component (un, gfc_new_block->name, &c))
3700 : : {
3701 : 0 : gfc_internal_error ("failed to create map component '%s'",
3702 : : gfc_new_block->name);
3703 : : reject_statement ();
3704 : : return;
3705 : : }
3706 : 257 : c->ts.type = BT_DERIVED;
3707 : 257 : c->ts.u.derived = gfc_new_block;
3708 : : /* Normally components get their initialization expressions when they
3709 : : are created in decl.cc (build_struct) so we can look through the
3710 : : flat component list for initializers during resolution. Unions and
3711 : : maps create components along with their type definitions so we
3712 : : have to generate initializers here. */
3713 : 257 : c->initializer = gfc_default_initializer (&c->ts);
3714 : 257 : break;
3715 : :
3716 : 132 : case ST_END_UNION:
3717 : 132 : compiling = 0;
3718 : 132 : accept_statement (ST_END_UNION);
3719 : 132 : break;
3720 : :
3721 : 2 : default:
3722 : 2 : unexpected_statement (st);
3723 : 2 : break;
3724 : : }
3725 : : }
3726 : :
3727 : 389 : for (c = un->components; c; c = c->next)
3728 : 257 : check_component (un, c, &lock_comp, &event_comp);
3729 : :
3730 : : /* Add the union as a component in its parent structure. */
3731 : 132 : pop_state ();
3732 : 132 : if (!gfc_add_component (gfc_current_block (), un->name, &c))
3733 : : {
3734 : 0 : gfc_internal_error ("failed to create union component '%s'", un->name);
3735 : : reject_statement ();
3736 : : return;
3737 : : }
3738 : 132 : c->ts.type = BT_UNION;
3739 : 132 : c->ts.u.derived = un;
3740 : 132 : c->initializer = gfc_default_initializer (&c->ts);
3741 : :
3742 : 132 : un->attr.zero_comp = un->components == NULL;
3743 : : }
3744 : :
3745 : :
3746 : : /* Parse a STRUCTURE or MAP. */
3747 : :
3748 : : static void
3749 : 570 : parse_struct_map (gfc_statement block)
3750 : : {
3751 : 570 : int compiling_type;
3752 : 570 : gfc_statement st;
3753 : 570 : gfc_state_data s;
3754 : 570 : gfc_symbol *sym;
3755 : 570 : gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
3756 : 570 : gfc_compile_state comp;
3757 : 570 : gfc_statement ends;
3758 : :
3759 : 570 : if (block == ST_STRUCTURE_DECL)
3760 : : {
3761 : : comp = COMP_STRUCTURE;
3762 : : ends = ST_END_STRUCTURE;
3763 : : }
3764 : : else
3765 : : {
3766 : 257 : gcc_assert (block == ST_MAP);
3767 : : comp = COMP_MAP;
3768 : : ends = ST_END_MAP;
3769 : : }
3770 : :
3771 : 570 : accept_statement(block);
3772 : 570 : push_state (&s, comp, gfc_new_block);
3773 : :
3774 : 570 : gfc_new_block->component_access = ACCESS_PUBLIC;
3775 : 570 : compiling_type = 1;
3776 : :
3777 : 570 : while (compiling_type)
3778 : : {
3779 : 1554 : st = next_statement ();
3780 : 1554 : switch (st)
3781 : : {
3782 : 0 : case ST_NONE:
3783 : 0 : unexpected_eof ();
3784 : :
3785 : : /* Nested structure declarations will be captured as ST_DATA_DECL. */
3786 : 5 : case ST_STRUCTURE_DECL:
3787 : : /* Let a more specific error make it to decode_statement(). */
3788 : 5 : if (gfc_error_check () == 0)
3789 : 0 : gfc_error ("Syntax error in nested structure declaration at %C");
3790 : 5 : reject_statement ();
3791 : : /* Skip the rest of this statement. */
3792 : 5 : gfc_error_recovery ();
3793 : 5 : break;
3794 : :
3795 : 132 : case ST_UNION:
3796 : 132 : accept_statement (ST_UNION);
3797 : 132 : parse_union ();
3798 : 132 : break;
3799 : :
3800 : 846 : case ST_DATA_DECL:
3801 : : /* The data declaration was a nested/ad-hoc STRUCTURE field. */
3802 : 846 : accept_statement (ST_DATA_DECL);
3803 : 846 : if (gfc_new_block && gfc_new_block != gfc_current_block ()
3804 : 21 : && gfc_new_block->attr.flavor == FL_STRUCT)
3805 : 21 : parse_struct_map (ST_STRUCTURE_DECL);
3806 : : break;
3807 : :
3808 : 570 : case ST_END_STRUCTURE:
3809 : 570 : case ST_END_MAP:
3810 : 570 : if (st == ends)
3811 : : {
3812 : 570 : accept_statement (st);
3813 : 570 : compiling_type = 0;
3814 : : }
3815 : : else
3816 : 0 : unexpected_statement (st);
3817 : : break;
3818 : :
3819 : 1 : default:
3820 : 1 : unexpected_statement (st);
3821 : 1 : break;
3822 : : }
3823 : : }
3824 : :
3825 : : /* Validate each component. */
3826 : 570 : sym = gfc_current_block ();
3827 : 1719 : for (c = sym->components; c; c = c->next)
3828 : 1149 : check_component (sym, c, &lock_comp, &event_comp);
3829 : :
3830 : 570 : sym->attr.zero_comp = (sym->components == NULL);
3831 : :
3832 : : /* Allow parse_union to find this structure to add to its list of maps. */
3833 : 570 : if (block == ST_MAP)
3834 : 257 : gfc_new_block = gfc_current_block ();
3835 : :
3836 : 570 : pop_state ();
3837 : 570 : }
3838 : :
3839 : :
3840 : : /* Parse a derived type. */
3841 : :
3842 : : static void
3843 : 11759 : parse_derived (void)
3844 : : {
3845 : 11759 : int compiling_type, seen_private, seen_sequence, seen_component;
3846 : 11759 : gfc_statement st;
3847 : 11759 : gfc_state_data s;
3848 : 11759 : gfc_symbol *sym;
3849 : 11759 : gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
3850 : :
3851 : 11759 : accept_statement (ST_DERIVED_DECL);
3852 : 11759 : push_state (&s, COMP_DERIVED, gfc_new_block);
3853 : :
3854 : 11759 : gfc_new_block->component_access = ACCESS_PUBLIC;
3855 : 11759 : seen_private = 0;
3856 : 11759 : seen_sequence = 0;
3857 : 11759 : seen_component = 0;
3858 : :
3859 : 11759 : compiling_type = 1;
3860 : :
3861 : 11759 : while (compiling_type)
3862 : : {
3863 : 27000 : st = next_statement ();
3864 : 27000 : switch (st)
3865 : : {
3866 : 0 : case ST_NONE:
3867 : 0 : unexpected_eof ();
3868 : :
3869 : 14677 : case ST_DATA_DECL:
3870 : 14677 : case ST_PROCEDURE:
3871 : 14677 : accept_statement (st);
3872 : 14677 : seen_component = 1;
3873 : 14677 : break;
3874 : :
3875 : 0 : case ST_FINAL:
3876 : 0 : gfc_error ("FINAL declaration at %C must be inside CONTAINS");
3877 : 0 : break;
3878 : :
3879 : 11759 : case ST_END_TYPE:
3880 : 11759 : endType:
3881 : 11759 : compiling_type = 0;
3882 : :
3883 : 11759 : if (!seen_component)
3884 : 1532 : gfc_notify_std (GFC_STD_F2003, "Derived type "
3885 : : "definition at %C without components");
3886 : :
3887 : 11759 : accept_statement (ST_END_TYPE);
3888 : 11759 : break;
3889 : :
3890 : 318 : case ST_PRIVATE:
3891 : 318 : if (!gfc_find_state (COMP_MODULE))
3892 : : {
3893 : 0 : gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3894 : : "a MODULE");
3895 : 0 : break;
3896 : : }
3897 : :
3898 : 318 : if (seen_component)
3899 : : {
3900 : 0 : gfc_error ("PRIVATE statement at %C must precede "
3901 : : "structure components");
3902 : 0 : break;
3903 : : }
3904 : :
3905 : 318 : if (seen_private)
3906 : 0 : gfc_error ("Duplicate PRIVATE statement at %C");
3907 : :
3908 : 318 : s.sym->component_access = ACCESS_PRIVATE;
3909 : :
3910 : 318 : accept_statement (ST_PRIVATE);
3911 : 318 : seen_private = 1;
3912 : 318 : break;
3913 : :
3914 : 244 : case ST_SEQUENCE:
3915 : 244 : if (seen_component)
3916 : : {
3917 : 0 : gfc_error ("SEQUENCE statement at %C must precede "
3918 : : "structure components");
3919 : 0 : break;
3920 : : }
3921 : :
3922 : 244 : if (gfc_current_block ()->attr.sequence)
3923 : 0 : gfc_warning (0, "SEQUENCE attribute at %C already specified in "
3924 : : "TYPE statement");
3925 : :
3926 : 244 : if (seen_sequence)
3927 : : {
3928 : 0 : gfc_error ("Duplicate SEQUENCE statement at %C");
3929 : : }
3930 : :
3931 : 244 : seen_sequence = 1;
3932 : 244 : gfc_add_sequence (&gfc_current_block ()->attr,
3933 : 244 : gfc_current_block ()->name, NULL);
3934 : 244 : break;
3935 : :
3936 : 2099 : case ST_CONTAINS:
3937 : 2099 : gfc_notify_std (GFC_STD_F2003,
3938 : : "CONTAINS block in derived type"
3939 : : " definition at %C");
3940 : :
3941 : 2099 : accept_statement (ST_CONTAINS);
3942 : 2099 : parse_derived_contains ();
3943 : 2099 : goto endType;
3944 : :
3945 : 2 : default:
3946 : 2 : unexpected_statement (st);
3947 : 2 : break;
3948 : : }
3949 : : }
3950 : :
3951 : : /* need to verify that all fields of the derived type are
3952 : : * interoperable with C if the type is declared to be bind(c)
3953 : : */
3954 : 11759 : sym = gfc_current_block ();
3955 : 28862 : for (c = sym->components; c; c = c->next)
3956 : 17103 : check_component (sym, c, &lock_comp, &event_comp);
3957 : :
3958 : 11759 : if (!seen_component)
3959 : 1532 : sym->attr.zero_comp = 1;
3960 : :
3961 : 11759 : pop_state ();
3962 : 11759 : }
3963 : :
3964 : :
3965 : : /* Parse an ENUM. */
3966 : :
3967 : : static void
3968 : 156 : parse_enum (void)
3969 : : {
3970 : 156 : gfc_statement st;
3971 : 156 : int compiling_enum;
3972 : 156 : gfc_state_data s;
3973 : 156 : int seen_enumerator = 0;
3974 : :
3975 : 156 : push_state (&s, COMP_ENUM, gfc_new_block);
3976 : :
3977 : 156 : compiling_enum = 1;
3978 : :
3979 : 156 : while (compiling_enum)
3980 : : {
3981 : 416 : st = next_statement ();
3982 : 416 : switch (st)
3983 : : {
3984 : 2 : case ST_NONE:
3985 : 2 : unexpected_eof ();
3986 : 256 : break;
3987 : :
3988 : 256 : case ST_ENUMERATOR:
3989 : 256 : seen_enumerator = 1;
3990 : 256 : accept_statement (st);
3991 : 256 : break;
3992 : :
3993 : 154 : case ST_END_ENUM:
3994 : 154 : compiling_enum = 0;
3995 : 154 : if (!seen_enumerator)
3996 : 3 : gfc_error ("ENUM declaration at %C has no ENUMERATORS");
3997 : 154 : accept_statement (st);
3998 : 154 : break;
3999 : :
4000 : 4 : default:
4001 : 4 : gfc_free_enum_history ();
4002 : 4 : unexpected_statement (st);
4003 : 4 : break;
4004 : : }
4005 : : }
4006 : 154 : pop_state ();
4007 : 154 : }
4008 : :
4009 : :
4010 : : /* Parse an interface. We must be able to deal with the possibility
4011 : : of recursive interfaces. The parse_spec() subroutine is mutually
4012 : : recursive with parse_interface(). */
4013 : :
4014 : : static gfc_statement parse_spec (gfc_statement);
4015 : :
4016 : : static void
4017 : 9546 : parse_interface (void)
4018 : : {
4019 : 9546 : gfc_compile_state new_state = COMP_NONE, current_state;
4020 : 9546 : gfc_symbol *prog_unit, *sym;
4021 : 9546 : gfc_interface_info save;
4022 : 9546 : gfc_state_data s1, s2;
4023 : 9546 : gfc_statement st;
4024 : :
4025 : 9546 : accept_statement (ST_INTERFACE);
4026 : :
4027 : 9546 : current_interface.ns = gfc_current_ns;
4028 : 9546 : save = current_interface;
4029 : :
4030 : 19092 : sym = (current_interface.type == INTERFACE_GENERIC
4031 : 5776 : || current_interface.type == INTERFACE_USER_OP)
4032 : 9701 : ? gfc_new_block : NULL;
4033 : :
4034 : 9546 : push_state (&s1, COMP_INTERFACE, sym);
4035 : 9546 : current_state = COMP_NONE;
4036 : :
4037 : 25171 : loop:
4038 : 25171 : gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
4039 : :
4040 : 25171 : st = next_statement ();
4041 : 25171 : switch (st)
4042 : : {
4043 : 2 : case ST_NONE:
4044 : 2 : unexpected_eof ();
4045 : :
4046 : 12706 : case ST_SUBROUTINE:
4047 : 12706 : case ST_FUNCTION:
4048 : 12706 : if (st == ST_SUBROUTINE)
4049 : : new_state = COMP_SUBROUTINE;
4050 : 5566 : else if (st == ST_FUNCTION)
4051 : 5566 : new_state = COMP_FUNCTION;
4052 : 12706 : if (gfc_new_block->attr.pointer)
4053 : : {
4054 : 31 : gfc_new_block->attr.pointer = 0;
4055 : 31 : gfc_new_block->attr.proc_pointer = 1;
4056 : : }
4057 : 12706 : if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
4058 : : gfc_new_block->formal, NULL))
4059 : : {
4060 : 2 : reject_statement ();
4061 : 2 : gfc_free_namespace (gfc_current_ns);
4062 : 2 : goto loop;
4063 : : }
4064 : : /* F2008 C1210 forbids the IMPORT statement in module procedure
4065 : : interface bodies and the flag is set to import symbols. */
4066 : 12704 : if (gfc_new_block->attr.module_procedure)
4067 : 376 : gfc_current_ns->has_import_set = 1;
4068 : 12704 : break;
4069 : :
4070 : 2916 : case ST_PROCEDURE:
4071 : 2916 : case ST_MODULE_PROC: /* The module procedure matcher makes
4072 : : sure the context is correct. */
4073 : 2916 : accept_statement (st);
4074 : 2916 : gfc_free_namespace (gfc_current_ns);
4075 : 2916 : goto loop;
4076 : :
4077 : 9543 : case ST_END_INTERFACE:
4078 : 9543 : gfc_free_namespace (gfc_current_ns);
4079 : 9543 : gfc_current_ns = current_interface.ns;
4080 : 9543 : goto done;
4081 : :
4082 : 4 : default:
4083 : 4 : gfc_error ("Unexpected %s statement in INTERFACE block at %C",
4084 : : gfc_ascii_statement (st));
4085 : 4 : current_interface = save;
4086 : 4 : reject_statement ();
4087 : 4 : gfc_free_namespace (gfc_current_ns);
4088 : 4 : goto loop;
4089 : : }
4090 : :
4091 : :
4092 : : /* Make sure that the generic name has the right attribute. */
4093 : 12704 : if (current_interface.type == INTERFACE_GENERIC
4094 : 4801 : && current_state == COMP_NONE)
4095 : : {
4096 : 2418 : if (new_state == COMP_FUNCTION && sym)
4097 : 646 : gfc_add_function (&sym->attr, sym->name, NULL);
4098 : 1772 : else if (new_state == COMP_SUBROUTINE && sym)
4099 : 1772 : gfc_add_subroutine (&sym->attr, sym->name, NULL);
4100 : :
4101 : : current_state = new_state;
4102 : : }
4103 : :
4104 : 12704 : if (current_interface.type == INTERFACE_ABSTRACT)
4105 : : {
4106 : 452 : gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
4107 : 452 : if (gfc_is_intrinsic_typename (gfc_new_block->name))
4108 : 1 : gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
4109 : : "cannot be the same as an intrinsic type",
4110 : : gfc_new_block->name);
4111 : : }
4112 : :
4113 : 12704 : push_state (&s2, new_state, gfc_new_block);
4114 : 12704 : accept_statement (st);
4115 : 12704 : prog_unit = gfc_new_block;
4116 : 12704 : prog_unit->formal_ns = gfc_current_ns;
4117 : :
4118 : 12705 : decl:
4119 : : /* Read data declaration statements. */
4120 : 12705 : st = parse_spec (ST_NONE);
4121 : 12704 : in_specification_block = true;
4122 : :
4123 : : /* Since the interface block does not permit an IMPLICIT statement,
4124 : : the default type for the function or the result must be taken
4125 : : from the formal namespace. */
4126 : 12704 : if (new_state == COMP_FUNCTION)
4127 : : {
4128 : 5564 : if (prog_unit->result == prog_unit
4129 : 5079 : && prog_unit->ts.type == BT_UNKNOWN)
4130 : 43 : gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
4131 : 5521 : else if (prog_unit->result != prog_unit
4132 : 485 : && prog_unit->result->ts.type == BT_UNKNOWN)
4133 : 10 : gfc_set_default_type (prog_unit->result, 1,
4134 : : prog_unit->formal_ns);
4135 : : }
4136 : :
4137 : 12704 : if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
4138 : : {
4139 : 1 : gfc_error ("Unexpected %s statement at %C in INTERFACE body",
4140 : : gfc_ascii_statement (st));
4141 : 1 : reject_statement ();
4142 : 1 : goto decl;
4143 : : }
4144 : :
4145 : : /* Add EXTERNAL attribute to function or subroutine. */
4146 : 12703 : if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
4147 : 12022 : gfc_add_external (&prog_unit->attr, &gfc_current_locus);
4148 : :
4149 : 12703 : current_interface = save;
4150 : 12703 : gfc_add_interface (prog_unit);
4151 : 12703 : pop_state ();
4152 : :
4153 : 12703 : if (current_interface.ns
4154 : 12703 : && current_interface.ns->proc_name
4155 : 12703 : && strcmp (current_interface.ns->proc_name->name,
4156 : : prog_unit->name) == 0)
4157 : 1 : gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
4158 : : "enclosing procedure", prog_unit->name,
4159 : : ¤t_interface.ns->proc_name->declared_at);
4160 : :
4161 : 12703 : goto loop;
4162 : :
4163 : 9543 : done:
4164 : 9543 : pop_state ();
4165 : 9543 : }
4166 : :
4167 : :
4168 : : /* Associate function characteristics by going back to the function
4169 : : declaration and rematching the prefix. */
4170 : :
4171 : : static match
4172 : 6593 : match_deferred_characteristics (gfc_typespec * ts)
4173 : : {
4174 : 6593 : locus loc;
4175 : 6593 : match m = MATCH_ERROR;
4176 : 6593 : char name[GFC_MAX_SYMBOL_LEN + 1];
4177 : :
4178 : 6593 : loc = gfc_current_locus;
4179 : :
4180 : 6593 : gfc_current_locus = gfc_current_block ()->declared_at;
4181 : :
4182 : 6593 : gfc_clear_error ();
4183 : 6593 : gfc_buffer_error (true);
4184 : 6593 : m = gfc_match_prefix (ts);
4185 : 6593 : gfc_buffer_error (false);
4186 : :
4187 : 6593 : if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
4188 : : {
4189 : 989 : ts->kind = 0;
4190 : :
4191 : 989 : if (!ts->u.derived)
4192 : 6593 : m = MATCH_ERROR;
4193 : : }
4194 : :
4195 : : /* Only permit one go at the characteristic association. */
4196 : 6593 : if (ts->kind == -1)
4197 : 3 : ts->kind = 0;
4198 : :
4199 : : /* Set the function locus correctly. If we have not found the
4200 : : function name, there is an error. */
4201 : 6593 : if (m == MATCH_YES
4202 : 6578 : && gfc_match ("function% %n", name) == MATCH_YES
4203 : 13171 : && strcmp (name, gfc_current_block ()->name) == 0)
4204 : : {
4205 : 6565 : gfc_current_block ()->declared_at = gfc_current_locus;
4206 : 6565 : gfc_commit_symbols ();
4207 : : }
4208 : : else
4209 : : {
4210 : 28 : gfc_error_check ();
4211 : 28 : gfc_undo_symbols ();
4212 : : }
4213 : :
4214 : 6593 : gfc_current_locus =loc;
4215 : 6593 : return m;
4216 : : }
4217 : :
4218 : :
4219 : : /* Check specification-expressions in the function result of the currently
4220 : : parsed block and ensure they are typed (give an IMPLICIT type if necessary).
4221 : : For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
4222 : : scope are not yet parsed so this has to be delayed up to parse_spec. */
4223 : :
4224 : : static bool
4225 : 10639 : check_function_result_typed (void)
4226 : : {
4227 : 10639 : gfc_typespec ts;
4228 : :
4229 : 10639 : gcc_assert (gfc_current_state () == COMP_FUNCTION);
4230 : :
4231 : 10639 : if (!gfc_current_ns->proc_name->result)
4232 : : return true;
4233 : :
4234 : 10639 : ts = gfc_current_ns->proc_name->result->ts;
4235 : :
4236 : : /* Check type-parameters, at the moment only CHARACTER lengths possible. */
4237 : : /* TODO: Extend when KIND type parameters are implemented. */
4238 : 10639 : if (ts.type == BT_CHARACTER && ts.u.cl && ts.u.cl->length)
4239 : : {
4240 : : /* Reject invalid type of specification expression for length. */
4241 : 467 : if (ts.u.cl->length->ts.type != BT_INTEGER)
4242 : : return false;
4243 : :
4244 : 300 : gfc_expr_check_typed (ts.u.cl->length, gfc_current_ns, true);
4245 : : }
4246 : :
4247 : : return true;
4248 : : }
4249 : :
4250 : :
4251 : : /* Parse a set of specification statements. Returns the statement
4252 : : that doesn't fit. */
4253 : :
4254 : : static gfc_statement
4255 : 95939 : parse_spec (gfc_statement st)
4256 : : {
4257 : 95939 : st_state ss;
4258 : 95939 : bool function_result_typed = false;
4259 : 95939 : bool bad_characteristic = false;
4260 : 95939 : gfc_typespec *ts;
4261 : :
4262 : 95939 : in_specification_block = true;
4263 : :
4264 : 95939 : verify_st_order (&ss, ST_NONE, false);
4265 : 95939 : if (st == ST_NONE)
4266 : 87259 : st = next_statement ();
4267 : :
4268 : : /* If we are not inside a function or don't have a result specified so far,
4269 : : do nothing special about it. */
4270 : 95939 : if (gfc_current_state () != COMP_FUNCTION)
4271 : : function_result_typed = true;
4272 : : else
4273 : : {
4274 : 18264 : gfc_symbol* proc = gfc_current_ns->proc_name;
4275 : 18264 : gcc_assert (proc);
4276 : :
4277 : 18264 : if (proc->result && proc->result->ts.type == BT_UNKNOWN)
4278 : 95939 : function_result_typed = true;
4279 : : }
4280 : :
4281 : 10530 : loop:
4282 : :
4283 : : /* If we're inside a BLOCK construct, some statements are disallowed.
4284 : : Check this here. Attribute declaration statements like INTENT, OPTIONAL
4285 : : or VALUE are also disallowed, but they don't have a particular ST_*
4286 : : key so we have to check for them individually in their matcher routine. */
4287 : 386219 : if (gfc_current_state () == COMP_BLOCK)
4288 : 2044 : switch (st)
4289 : : {
4290 : 5 : case ST_IMPLICIT:
4291 : 5 : case ST_IMPLICIT_NONE:
4292 : 5 : case ST_NAMELIST:
4293 : 5 : case ST_COMMON:
4294 : 5 : case ST_EQUIVALENCE:
4295 : 5 : case ST_STATEMENT_FUNCTION:
4296 : 5 : gfc_error ("%s statement is not allowed inside of BLOCK at %C",
4297 : : gfc_ascii_statement (st));
4298 : 5 : reject_statement ();
4299 : 5 : break;
4300 : :
4301 : : default:
4302 : : break;
4303 : : }
4304 : 384175 : else if (gfc_current_state () == COMP_BLOCK_DATA)
4305 : : /* Fortran 2008, C1116. */
4306 : 401 : switch (st)
4307 : : {
4308 : : case ST_ATTR_DECL:
4309 : : case ST_COMMON:
4310 : : case ST_DATA:
4311 : : case ST_DATA_DECL:
4312 : : case ST_DERIVED_DECL:
4313 : : case ST_END_BLOCK_DATA:
4314 : : case ST_EQUIVALENCE:
4315 : : case ST_IMPLICIT:
4316 : : case ST_IMPLICIT_NONE:
4317 : : case ST_OMP_THREADPRIVATE:
4318 : : case ST_PARAMETER:
4319 : : case ST_STRUCTURE_DECL:
4320 : : case ST_TYPE:
4321 : : case ST_USE:
4322 : : break;
4323 : :
4324 : : case ST_NONE:
4325 : : break;
4326 : :
4327 : 5 : default:
4328 : 5 : gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
4329 : : gfc_ascii_statement (st));
4330 : 5 : reject_statement ();
4331 : 5 : break;
4332 : : }
4333 : :
4334 : : /* If we find a statement that cannot be followed by an IMPLICIT statement
4335 : : (and thus we can expect to see none any further), type the function result
4336 : : if it has not yet been typed. Be careful not to give the END statement
4337 : : to verify_st_order! */
4338 : 386219 : if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
4339 : : {
4340 : 12364 : bool verify_now = false;
4341 : :
4342 : 12364 : if (st == ST_END_FUNCTION || st == ST_CONTAINS)
4343 : : verify_now = true;
4344 : : else
4345 : : {
4346 : 12080 : st_state dummyss;
4347 : 12080 : verify_st_order (&dummyss, ST_NONE, false);
4348 : 12080 : verify_st_order (&dummyss, st, false);
4349 : :
4350 : 12080 : if (!verify_st_order (&dummyss, ST_IMPLICIT, true))
4351 : 9581 : verify_now = true;
4352 : : }
4353 : :
4354 : 12080 : if (verify_now)
4355 : 9865 : function_result_typed = check_function_result_typed ();
4356 : : }
4357 : :
4358 : 386219 : switch (st)
4359 : : {
4360 : 12 : case ST_NONE:
4361 : 12 : unexpected_eof ();
4362 : :
4363 : 22637 : case ST_IMPLICIT_NONE:
4364 : 22637 : case ST_IMPLICIT:
4365 : 22637 : if (!function_result_typed)
4366 : 774 : function_result_typed = check_function_result_typed ();
4367 : 22637 : goto declSt;
4368 : :
4369 : 2911 : case ST_FORMAT:
4370 : 2911 : case ST_ENTRY:
4371 : 2911 : case ST_DATA: /* Not allowed in interfaces */
4372 : 2911 : if (gfc_current_state () == COMP_INTERFACE)
4373 : : break;
4374 : :
4375 : : /* Fall through */
4376 : :
4377 : 283539 : case ST_USE:
4378 : 283539 : case ST_IMPORT:
4379 : 283539 : case ST_PARAMETER:
4380 : 283539 : case ST_PUBLIC:
4381 : 283539 : case ST_PRIVATE:
4382 : 283539 : case ST_STRUCTURE_DECL:
4383 : 283539 : case ST_DERIVED_DECL:
4384 : 283539 : case_decl:
4385 : 283539 : case_omp_decl:
4386 : 2911 : declSt:
4387 : 283539 : if (!verify_st_order (&ss, st, false))
4388 : : {
4389 : 1 : reject_statement ();
4390 : 1 : st = next_statement ();
4391 : 1 : goto loop;
4392 : : }
4393 : :
4394 : 283538 : switch (st)
4395 : : {
4396 : 9546 : case ST_INTERFACE:
4397 : 9546 : parse_interface ();
4398 : 9546 : break;
4399 : :
4400 : 292 : case ST_STRUCTURE_DECL:
4401 : 292 : parse_struct_map (ST_STRUCTURE_DECL);
4402 : 292 : break;
4403 : :
4404 : 11759 : case ST_DERIVED_DECL:
4405 : 11759 : parse_derived ();
4406 : 11759 : break;
4407 : :
4408 : 870 : case ST_PUBLIC:
4409 : 870 : case ST_PRIVATE:
4410 : 870 : if (gfc_current_state () != COMP_MODULE)
4411 : : {
4412 : 0 : gfc_error ("%s statement must appear in a MODULE",
4413 : : gfc_ascii_statement (st));
4414 : 0 : reject_statement ();
4415 : 0 : break;
4416 : : }
4417 : :
4418 : 870 : if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
4419 : : {
4420 : 0 : gfc_error ("%s statement at %C follows another accessibility "
4421 : : "specification", gfc_ascii_statement (st));
4422 : 0 : reject_statement ();
4423 : 0 : break;
4424 : : }
4425 : :
4426 : 1740 : gfc_current_ns->default_access = (st == ST_PUBLIC)
4427 : 870 : ? ACCESS_PUBLIC : ACCESS_PRIVATE;
4428 : :
4429 : 870 : break;
4430 : :
4431 : 224 : case ST_STATEMENT_FUNCTION:
4432 : 224 : if (gfc_current_state () == COMP_MODULE
4433 : 224 : || gfc_current_state () == COMP_SUBMODULE)
4434 : : {
4435 : 1 : unexpected_statement (st);
4436 : 1 : break;
4437 : : }
4438 : :
4439 : : default:
4440 : : break;
4441 : : }
4442 : :
4443 : 283535 : accept_statement (st);
4444 : 283535 : st = next_statement ();
4445 : 283532 : goto loop;
4446 : :
4447 : 156 : case ST_ENUM:
4448 : 156 : accept_statement (st);
4449 : 156 : parse_enum();
4450 : 154 : st = next_statement ();
4451 : 154 : goto loop;
4452 : :
4453 : 6593 : case ST_GET_FCN_CHARACTERISTICS:
4454 : : /* This statement triggers the association of a function's result
4455 : : characteristics. */
4456 : 6593 : ts = &gfc_current_block ()->result->ts;
4457 : 6593 : if (match_deferred_characteristics (ts) != MATCH_YES)
4458 : 15 : bad_characteristic = true;
4459 : :
4460 : 6593 : st = next_statement ();
4461 : 6593 : goto loop;
4462 : :
4463 : : default:
4464 : : break;
4465 : : }
4466 : :
4467 : : /* If match_deferred_characteristics failed, then there is an error. */
4468 : 95919 : if (bad_characteristic)
4469 : : {
4470 : 15 : ts = &gfc_current_block ()->result->ts;
4471 : 15 : if (ts->type != BT_DERIVED && ts->type != BT_CLASS)
4472 : 5 : gfc_error ("Bad kind expression for function %qs at %L",
4473 : : gfc_current_block ()->name,
4474 : : &gfc_current_block ()->declared_at);
4475 : : else
4476 : 10 : gfc_error ("The type for function %qs at %L is not accessible",
4477 : : gfc_current_block ()->name,
4478 : : &gfc_current_block ()->declared_at);
4479 : :
4480 : 15 : gfc_current_block ()->ts.kind = 0;
4481 : : /* Keep the derived type; if it's bad, it will be discovered later. */
4482 : 15 : if (!(ts->type == BT_DERIVED && ts->u.derived))
4483 : 15 : ts->type = BT_UNKNOWN;
4484 : : }
4485 : :
4486 : 95919 : in_specification_block = false;
4487 : :
4488 : 95919 : return st;
4489 : : }
4490 : :
4491 : :
4492 : : /* Parse a WHERE block, (not a simple WHERE statement). */
4493 : :
4494 : : static void
4495 : 371 : parse_where_block (void)
4496 : : {
4497 : 371 : int seen_empty_else;
4498 : 371 : gfc_code *top, *d;
4499 : 371 : gfc_state_data s;
4500 : 371 : gfc_statement st;
4501 : :
4502 : 371 : accept_statement (ST_WHERE_BLOCK);
4503 : 371 : top = gfc_state_stack->tail;
4504 : :
4505 : 371 : push_state (&s, COMP_WHERE, gfc_new_block);
4506 : :
4507 : 371 : d = add_statement ();
4508 : 371 : d->expr1 = top->expr1;
4509 : 371 : d->op = EXEC_WHERE;
4510 : :
4511 : 371 : top->expr1 = NULL;
4512 : 371 : top->block = d;
4513 : :
4514 : 371 : seen_empty_else = 0;
4515 : :
4516 : 1342 : do
4517 : : {
4518 : 1342 : st = next_statement ();
4519 : 1342 : switch (st)
4520 : : {
4521 : 0 : case ST_NONE:
4522 : 0 : unexpected_eof ();
4523 : :
4524 : 40 : case ST_WHERE_BLOCK:
4525 : 40 : parse_where_block ();
4526 : 40 : break;
4527 : :
4528 : 619 : case ST_ASSIGNMENT:
4529 : 619 : case ST_WHERE:
4530 : 619 : accept_statement (st);
4531 : 619 : break;
4532 : :
4533 : 312 : case ST_ELSEWHERE:
4534 : 312 : if (seen_empty_else)
4535 : : {
4536 : 1 : gfc_error ("ELSEWHERE statement at %C follows previous "
4537 : : "unmasked ELSEWHERE");
4538 : 1 : reject_statement ();
4539 : 1 : break;
4540 : : }
4541 : :
4542 : 311 : if (new_st.expr1 == NULL)
4543 : 133 : seen_empty_else = 1;
4544 : :
4545 : 311 : d = new_level (gfc_state_stack->head);
4546 : 311 : d->op = EXEC_WHERE;
4547 : 311 : d->expr1 = new_st.expr1;
4548 : :
4549 : 311 : accept_statement (st);
4550 : :
4551 : 311 : break;
4552 : :
4553 : 371 : case ST_END_WHERE:
4554 : 371 : accept_statement (st);
4555 : 371 : break;
4556 : :
4557 : 0 : default:
4558 : 0 : gfc_error ("Unexpected %s statement in WHERE block at %C",
4559 : : gfc_ascii_statement (st));
4560 : 0 : reject_statement ();
4561 : 0 : break;
4562 : : }
4563 : : }
4564 : 1342 : while (st != ST_END_WHERE);
4565 : :
4566 : 371 : pop_state ();
4567 : 371 : }
4568 : :
4569 : :
4570 : : /* Parse a FORALL block (not a simple FORALL statement). */
4571 : :
4572 : : static void
4573 : 513 : parse_forall_block (void)
4574 : : {
4575 : 513 : gfc_code *top, *d;
4576 : 513 : gfc_state_data s;
4577 : 513 : gfc_statement st;
4578 : :
4579 : 513 : accept_statement (ST_FORALL_BLOCK);
4580 : 513 : top = gfc_state_stack->tail;
4581 : :
4582 : 513 : push_state (&s, COMP_FORALL, gfc_new_block);
4583 : :
4584 : 513 : d = add_statement ();
4585 : 513 : d->op = EXEC_FORALL;
4586 : 513 : top->block = d;
4587 : :
4588 : 1039 : do
4589 : : {
4590 : 1039 : st = next_statement ();
4591 : 1039 : switch (st)
4592 : : {
4593 : :
4594 : 397 : case ST_ASSIGNMENT:
4595 : 397 : case ST_POINTER_ASSIGNMENT:
4596 : 397 : case ST_WHERE:
4597 : 397 : case ST_FORALL:
4598 : 397 : accept_statement (st);
4599 : 397 : break;
4600 : :
4601 : 46 : case ST_WHERE_BLOCK:
4602 : 46 : parse_where_block ();
4603 : 46 : break;
4604 : :
4605 : 83 : case ST_FORALL_BLOCK:
4606 : 83 : parse_forall_block ();
4607 : 83 : break;
4608 : :
4609 : 513 : case ST_END_FORALL:
4610 : 513 : accept_statement (st);
4611 : 513 : break;
4612 : :
4613 : 0 : case ST_NONE:
4614 : 0 : unexpected_eof ();
4615 : :
4616 : 0 : default:
4617 : 0 : gfc_error ("Unexpected %s statement in FORALL block at %C",
4618 : : gfc_ascii_statement (st));
4619 : :
4620 : 0 : reject_statement ();
4621 : 0 : break;
4622 : : }
4623 : : }
4624 : 1039 : while (st != ST_END_FORALL);
4625 : :
4626 : 513 : pop_state ();
4627 : 513 : }
4628 : :
4629 : :
4630 : : static gfc_statement parse_executable (gfc_statement);
4631 : :
4632 : : /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
4633 : :
4634 : : static void
4635 : 14053 : parse_if_block (void)
4636 : : {
4637 : 14053 : gfc_code *top, *d;
4638 : 14053 : gfc_statement st;
4639 : 14053 : locus else_locus;
4640 : 14053 : gfc_state_data s;
4641 : 14053 : int seen_else;
4642 : :
4643 : 14053 : seen_else = 0;
4644 : 14053 : accept_statement (ST_IF_BLOCK);
4645 : :
4646 : 14053 : top = gfc_state_stack->tail;
4647 : 14053 : push_state (&s, COMP_IF, gfc_new_block);
4648 : :
4649 : 14053 : new_st.op = EXEC_IF;
4650 : 14053 : d = add_statement ();
4651 : :
4652 : 14053 : d->expr1 = top->expr1;
4653 : 14053 : top->expr1 = NULL;
4654 : 14053 : top->block = d;
4655 : :
4656 : 19902 : do
4657 : : {
4658 : 19902 : st = parse_executable (ST_NONE);
4659 : :
4660 : 19901 : switch (st)
4661 : : {
4662 : 0 : case ST_NONE:
4663 : 0 : unexpected_eof ();
4664 : :
4665 : 1925 : case ST_ELSEIF:
4666 : 1925 : if (seen_else)
4667 : : {
4668 : 0 : gfc_error ("ELSE IF statement at %C cannot follow ELSE "
4669 : : "statement at %L", &else_locus);
4670 : :
4671 : 0 : reject_statement ();
4672 : 0 : break;
4673 : : }
4674 : :
4675 : 1925 : d = new_level (gfc_state_stack->head);
4676 : 1925 : d->op = EXEC_IF;
4677 : 1925 : d->expr1 = new_st.expr1;
4678 : :
4679 : 1925 : accept_statement (st);
4680 : :
4681 : 1925 : break;
4682 : :
4683 : 3922 : case ST_ELSE:
4684 : 3922 : if (seen_else)
4685 : : {
4686 : 0 : gfc_error ("Duplicate ELSE statements at %L and %C",
4687 : : &else_locus);
4688 : 0 : reject_statement ();
4689 : 0 : break;
4690 : : }
4691 : :
4692 : 3922 : seen_else = 1;
4693 : 3922 : else_locus = gfc_current_locus;
4694 : :
4695 : 3922 : d = new_level (gfc_state_stack->head);
4696 : 3922 : d->op = EXEC_IF;
4697 : :
4698 : 3922 : accept_statement (st);
4699 : :
4700 : 3922 : break;
4701 : :
4702 : : case ST_ENDIF:
4703 : : break;
4704 : :
4705 : 2 : default:
4706 : 2 : unexpected_statement (st);
4707 : 2 : break;
4708 : : }
4709 : : }
4710 : 19901 : while (st != ST_ENDIF);
4711 : :
4712 : 14052 : pop_state ();
4713 : 14052 : accept_statement (st);
4714 : 14052 : }
4715 : :
4716 : :
4717 : : /* Parse a SELECT block. */
4718 : :
4719 : : static void
4720 : 553 : parse_select_block (void)
4721 : : {
4722 : 553 : gfc_statement st;
4723 : 553 : gfc_code *cp;
4724 : 553 : gfc_state_data s;
4725 : :
4726 : 553 : accept_statement (ST_SELECT_CASE);
4727 : :
4728 : 553 : cp = gfc_state_stack->tail;
4729 : 553 : push_state (&s, COMP_SELECT, gfc_new_block);
4730 : :
4731 : : /* Make sure that the next statement is a CASE or END SELECT. */
4732 : 555 : for (;;)
4733 : : {
4734 : 554 : st = next_statement ();
4735 : 554 : if (st == ST_NONE)
4736 : 0 : unexpected_eof ();
4737 : 554 : if (st == ST_END_SELECT)
4738 : : {
4739 : : /* Empty SELECT CASE is OK. */
4740 : 14 : accept_statement (st);
4741 : 14 : pop_state ();
4742 : 14 : return;
4743 : : }
4744 : 540 : if (st == ST_CASE)
4745 : : break;
4746 : :
4747 : 1 : gfc_error ("Expected a CASE or END SELECT statement following SELECT "
4748 : : "CASE at %C");
4749 : :
4750 : 1 : reject_statement ();
4751 : : }
4752 : :
4753 : : /* At this point, we've got a nonempty select block. */
4754 : 539 : cp = new_level (cp);
4755 : 539 : *cp = new_st;
4756 : :
4757 : 539 : accept_statement (st);
4758 : :
4759 : 1640 : do
4760 : : {
4761 : 1640 : st = parse_executable (ST_NONE);
4762 : 1640 : switch (st)
4763 : : {
4764 : 0 : case ST_NONE:
4765 : 0 : unexpected_eof ();
4766 : :
4767 : 1101 : case ST_CASE:
4768 : 1101 : cp = new_level (gfc_state_stack->head);
4769 : 1101 : *cp = new_st;
4770 : 1101 : gfc_clear_new_st ();
4771 : :
4772 : 1101 : accept_statement (st);
4773 : : /* Fall through */
4774 : :
4775 : : case ST_END_SELECT:
4776 : : break;
4777 : :
4778 : : /* Can't have an executable statement because of
4779 : : parse_executable(). */
4780 : 0 : default:
4781 : 0 : unexpected_statement (st);
4782 : 0 : break;
4783 : : }
4784 : : }
4785 : 1640 : while (st != ST_END_SELECT);
4786 : :
4787 : 539 : pop_state ();
4788 : 539 : accept_statement (st);
4789 : : }
4790 : :
4791 : :
4792 : : /* Pop the current selector from the SELECT TYPE stack. */
4793 : :
4794 : : static void
4795 : 3875 : select_type_pop (void)
4796 : : {
4797 : 3875 : gfc_select_type_stack *old = select_type_stack;
4798 : 3875 : select_type_stack = old->prev;
4799 : 3875 : free (old);
4800 : 3875 : }
4801 : :
4802 : :
4803 : : /* Parse a SELECT TYPE construct (F03:R821). */
4804 : :
4805 : : static void
4806 : 2859 : parse_select_type_block (void)
4807 : : {
4808 : 2859 : gfc_statement st;
4809 : 2859 : gfc_code *cp;
4810 : 2859 : gfc_state_data s;
4811 : :
4812 : 2859 : gfc_current_ns = new_st.ext.block.ns;
4813 : 2859 : accept_statement (ST_SELECT_TYPE);
4814 : :
4815 : 2859 : cp = gfc_state_stack->tail;
4816 : 2859 : push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
4817 : :
4818 : : /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
4819 : : or END SELECT. */
4820 : 2869 : for (;;)
4821 : : {
4822 : 2864 : st = next_statement ();
4823 : 2864 : if (st == ST_NONE)
4824 : 2 : unexpected_eof ();
4825 : 2862 : if (st == ST_END_SELECT)
4826 : : /* Empty SELECT CASE is OK. */
4827 : 22 : goto done;
4828 : 2840 : if (st == ST_TYPE_IS || st == ST_CLASS_IS)
4829 : : break;
4830 : :
4831 : 5 : gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
4832 : : "following SELECT TYPE at %C");
4833 : :
4834 : 5 : reject_statement ();
4835 : : }
4836 : :
4837 : : /* At this point, we've got a nonempty select block. */
4838 : 2835 : cp = new_level (cp);
4839 : 2835 : *cp = new_st;
4840 : :
4841 : 2835 : accept_statement (st);
4842 : :
4843 : 5137 : do
4844 : : {
4845 : 5137 : st = parse_executable (ST_NONE);
4846 : 5137 : switch (st)
4847 : : {
4848 : 0 : case ST_NONE:
4849 : 0 : unexpected_eof ();
4850 : :
4851 : 2302 : case ST_TYPE_IS:
4852 : 2302 : case ST_CLASS_IS:
4853 : 2302 : cp = new_level (gfc_state_stack->head);
4854 : 2302 : *cp = new_st;
4855 : 2302 : gfc_clear_new_st ();
4856 : :
4857 : 2302 : accept_statement (st);
4858 : : /* Fall through */
4859 : :
4860 : : case ST_END_SELECT:
4861 : : break;
4862 : :
4863 : : /* Can't have an executable statement because of
4864 : : parse_executable(). */
4865 : 0 : default:
4866 : 0 : unexpected_statement (st);
4867 : 0 : break;
4868 : : }
4869 : : }
4870 : 5137 : while (st != ST_END_SELECT);
4871 : :
4872 : 2835 : done:
4873 : 2857 : pop_state ();
4874 : 2857 : accept_statement (st);
4875 : 2857 : gfc_current_ns = gfc_current_ns->parent;
4876 : 2857 : select_type_pop ();
4877 : 2857 : }
4878 : :
4879 : :
4880 : : /* Parse a SELECT RANK construct. */
4881 : :
4882 : : static void
4883 : 1018 : parse_select_rank_block (void)
4884 : : {
4885 : 1018 : gfc_statement st;
4886 : 1018 : gfc_code *cp;
4887 : 1018 : gfc_state_data s;
4888 : :
4889 : 1018 : gfc_current_ns = new_st.ext.block.ns;
4890 : 1018 : accept_statement (ST_SELECT_RANK);
4891 : :
4892 : 1018 : cp = gfc_state_stack->tail;
4893 : 1018 : push_state (&s, COMP_SELECT_RANK, gfc_new_block);
4894 : :
4895 : : /* Make sure that the next statement is a RANK IS or RANK DEFAULT. */
4896 : 1024 : for (;;)
4897 : : {
4898 : 1021 : st = next_statement ();
4899 : 1021 : if (st == ST_NONE)
4900 : 0 : unexpected_eof ();
4901 : 1021 : if (st == ST_END_SELECT)
4902 : : /* Empty SELECT CASE is OK. */
4903 : 3 : goto done;
4904 : 1018 : if (st == ST_RANK)
4905 : : break;
4906 : :
4907 : 3 : gfc_error ("Expected RANK or RANK DEFAULT "
4908 : : "following SELECT RANK at %C");
4909 : :
4910 : 3 : reject_statement ();
4911 : : }
4912 : :
4913 : : /* At this point, we've got a nonempty select block. */
4914 : 1015 : cp = new_level (cp);
4915 : 1015 : *cp = new_st;
4916 : :
4917 : 1015 : accept_statement (st);
4918 : :
4919 : 2302 : do
4920 : : {
4921 : 2302 : st = parse_executable (ST_NONE);
4922 : 2302 : switch (st)
4923 : : {
4924 : 0 : case ST_NONE:
4925 : 0 : unexpected_eof ();
4926 : :
4927 : 1287 : case ST_RANK:
4928 : 1287 : cp = new_level (gfc_state_stack->head);
4929 : 1287 : *cp = new_st;
4930 : 1287 : gfc_clear_new_st ();
4931 : :
4932 : 1287 : accept_statement (st);
4933 : : /* Fall through */
4934 : :
4935 : : case ST_END_SELECT:
4936 : : break;
4937 : :
4938 : : /* Can't have an executable statement because of
4939 : : parse_executable(). */
4940 : 0 : default:
4941 : 0 : unexpected_statement (st);
4942 : 0 : break;
4943 : : }
4944 : : }
4945 : 2302 : while (st != ST_END_SELECT);
4946 : :
4947 : 1015 : done:
4948 : 1018 : pop_state ();
4949 : 1018 : accept_statement (st);
4950 : 1018 : gfc_current_ns = gfc_current_ns->parent;
4951 : 1018 : select_type_pop ();
4952 : 1018 : }
4953 : :
4954 : :
4955 : : /* Given a symbol, make sure it is not an iteration variable for a DO
4956 : : statement. This subroutine is called when the symbol is seen in a
4957 : : context that causes it to become redefined. If the symbol is an
4958 : : iterator, we generate an error message and return nonzero. */
4959 : :
4960 : : bool
4961 : 252992 : gfc_check_do_variable (gfc_symtree *st)
4962 : : {
4963 : 252992 : gfc_state_data *s;
4964 : :
4965 : 252992 : if (!st)
4966 : : return 0;
4967 : :
4968 : 1078487 : for (s=gfc_state_stack; s; s = s->previous)
4969 : 825508 : if (s->do_variable == st)
4970 : : {
4971 : 8 : gfc_error_now ("Variable %qs at %C cannot be redefined inside "
4972 : 8 : "loop beginning at %L", st->name, &s->head->loc);
4973 : 8 : return 1;
4974 : : }
4975 : :
4976 : : return 0;
4977 : : }
4978 : :
4979 : :
4980 : : /* Checks to see if the current statement label closes an enddo.
4981 : : Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
4982 : : an error) if it incorrectly closes an ENDDO. */
4983 : :
4984 : : static int
4985 : 776868 : check_do_closure (void)
4986 : : {
4987 : 776868 : gfc_state_data *p;
4988 : :
4989 : 776868 : if (gfc_statement_label == NULL)
4990 : : return 0;
4991 : :
4992 : 15790 : for (p = gfc_state_stack; p; p = p->previous)
4993 : 12180 : if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
4994 : : break;
4995 : :
4996 : 6636 : if (p == NULL)
4997 : : return 0; /* No loops to close */
4998 : :
4999 : 3026 : if (p->ext.end_do_label == gfc_statement_label)
5000 : : {
5001 : 2235 : if (p == gfc_state_stack)
5002 : : return 1;
5003 : :
5004 : 1 : gfc_error ("End of nonblock DO statement at %C is within another block");
5005 : 1 : return 2;
5006 : : }
5007 : :
5008 : : /* At this point, the label doesn't terminate the innermost loop.
5009 : : Make sure it doesn't terminate another one. */
5010 : 4480 : for (; p; p = p->previous)
5011 : 3689 : if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
5012 : 1041 : && p->ext.end_do_label == gfc_statement_label)
5013 : : {
5014 : 0 : gfc_error ("End of nonblock DO statement at %C is interwoven "
5015 : : "with another DO loop");
5016 : 0 : return 2;
5017 : : }
5018 : :
5019 : : return 0;
5020 : : }
5021 : :
5022 : :
5023 : : /* Parse a series of contained program units. */
5024 : :
5025 : : static void parse_progunit (gfc_statement);
5026 : :
5027 : :
5028 : : /* Parse a CRITICAL block. */
5029 : :
5030 : : static void
5031 : 33 : parse_critical_block (void)
5032 : : {
5033 : 33 : gfc_code *top, *d;
5034 : 33 : gfc_state_data s, *sd;
5035 : 33 : gfc_statement st;
5036 : :
5037 : 115 : for (sd = gfc_state_stack; sd; sd = sd->previous)
5038 : 82 : if (sd->state == COMP_OMP_STRUCTURED_BLOCK)
5039 : 2 : gfc_error_now (is_oacc (sd)
5040 : : ? G_("CRITICAL block inside of OpenACC region at %C")
5041 : : : G_("CRITICAL block inside of OpenMP region at %C"));
5042 : :
5043 : 33 : s.ext.end_do_label = new_st.label1;
5044 : :
5045 : 33 : accept_statement (ST_CRITICAL);
5046 : 33 : top = gfc_state_stack->tail;
5047 : :
5048 : 33 : push_state (&s, COMP_CRITICAL, gfc_new_block);
5049 : :
5050 : 33 : d = add_statement ();
5051 : 33 : d->op = EXEC_CRITICAL;
5052 : 33 : top->block = d;
5053 : :
5054 : 33 : do
5055 : : {
5056 : 33 : st = parse_executable (ST_NONE);
5057 : :
5058 : 33 : switch (st)
5059 : : {
5060 : 0 : case ST_NONE:
5061 : 0 : unexpected_eof ();
5062 : 33 : break;
5063 : :
5064 : 33 : case ST_END_CRITICAL:
5065 : 33 : if (s.ext.end_do_label != NULL
5066 : 0 : && s.ext.end_do_label != gfc_statement_label)
5067 : 0 : gfc_error_now ("Statement label in END CRITICAL at %C does not "
5068 : : "match CRITICAL label");
5069 : :
5070 : 33 : if (gfc_statement_label != NULL)
5071 : : {
5072 : 1 : new_st.op = EXEC_NOP;
5073 : 1 : add_statement ();
5074 : : }
5075 : : break;
5076 : :
5077 : 0 : default:
5078 : 0 : unexpected_statement (st);
5079 : 0 : break;
5080 : : }
5081 : : }
5082 : 33 : while (st != ST_END_CRITICAL);
5083 : :
5084 : 33 : pop_state ();
5085 : 33 : accept_statement (st);
5086 : 33 : }
5087 : :
5088 : :
5089 : : /* Set up the local namespace for a BLOCK construct. */
5090 : :
5091 : : gfc_namespace*
5092 : 13765 : gfc_build_block_ns (gfc_namespace *parent_ns)
5093 : : {
5094 : 13765 : gfc_namespace* my_ns;
5095 : 13765 : static int numblock = 1;
5096 : :
5097 : 13765 : my_ns = gfc_get_namespace (parent_ns, 1);
5098 : 13765 : my_ns->construct_entities = 1;
5099 : :
5100 : : /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
5101 : : code generation (so it must not be NULL).
5102 : : We set its recursive argument if our container procedure is recursive, so
5103 : : that local variables are accordingly placed on the stack when it
5104 : : will be necessary. */
5105 : 13765 : if (gfc_new_block)
5106 : 130 : my_ns->proc_name = gfc_new_block;
5107 : : else
5108 : : {
5109 : 13635 : bool t;
5110 : 13635 : char buffer[20]; /* Enough to hold "block@2147483648\n". */
5111 : :
5112 : 13635 : snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
5113 : 13635 : gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
5114 : 27270 : t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
5115 : 13635 : my_ns->proc_name->name, NULL);
5116 : 13635 : gcc_assert (t);
5117 : 13635 : gfc_commit_symbol (my_ns->proc_name);
5118 : : }
5119 : :
5120 : 13765 : if (parent_ns->proc_name)
5121 : 13762 : my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
5122 : :
5123 : 13765 : return my_ns;
5124 : : }
5125 : :
5126 : :
5127 : : /* Parse a BLOCK construct. */
5128 : :
5129 : : static void
5130 : 884 : parse_block_construct (void)
5131 : : {
5132 : 884 : gfc_namespace* my_ns;
5133 : 884 : gfc_namespace* my_parent;
5134 : 884 : gfc_state_data s;
5135 : :
5136 : 884 : gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
5137 : :
5138 : 884 : my_ns = gfc_build_block_ns (gfc_current_ns);
5139 : :
5140 : 884 : new_st.op = EXEC_BLOCK;
5141 : 884 : new_st.ext.block.ns = my_ns;
5142 : 884 : new_st.ext.block.assoc = NULL;
5143 : 884 : accept_statement (ST_BLOCK);
5144 : :
5145 : 884 : push_state (&s, COMP_BLOCK, my_ns->proc_name);
5146 : 884 : gfc_current_ns = my_ns;
5147 : 884 : my_parent = my_ns->parent;
5148 : :
5149 : 884 : parse_progunit (ST_NONE);
5150 : :
5151 : : /* Don't depend on the value of gfc_current_ns; it might have been
5152 : : reset if the block had errors and was cleaned up. */
5153 : 876 : gfc_current_ns = my_parent;
5154 : :
5155 : 876 : pop_state ();
5156 : 876 : }
5157 : :
5158 : :
5159 : : /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
5160 : : behind the scenes with compiler-generated variables. */
5161 : :
5162 : : static void
5163 : 1278 : parse_associate (void)
5164 : : {
5165 : 1278 : gfc_namespace* my_ns;
5166 : 1278 : gfc_state_data s;
5167 : 1278 : gfc_statement st;
5168 : 1278 : gfc_association_list* a;
5169 : 1278 : gfc_array_spec *as;
5170 : :
5171 : 1278 : gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
5172 : :
5173 : 1278 : my_ns = gfc_build_block_ns (gfc_current_ns);
5174 : :
5175 : 1278 : new_st.op = EXEC_BLOCK;
5176 : 1278 : new_st.ext.block.ns = my_ns;
5177 : 1278 : gcc_assert (new_st.ext.block.assoc);
5178 : :
5179 : : /* Add all associate-names as BLOCK variables. Creating them is enough
5180 : : for now, they'll get their values during trans-* phase. */
5181 : 1278 : gfc_current_ns = my_ns;
5182 : 2662 : for (a = new_st.ext.block.assoc; a; a = a->next)
5183 : : {
5184 : 1384 : gfc_symbol *sym, *tsym;
5185 : 1384 : gfc_expr *target;
5186 : 1384 : int rank, corank;
5187 : :
5188 : 1384 : if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
5189 : 0 : gcc_unreachable ();
5190 : :
5191 : 1384 : sym = a->st->n.sym;
5192 : 1384 : sym->attr.flavor = FL_VARIABLE;
5193 : 1384 : sym->assoc = a;
5194 : 1384 : sym->declared_at = a->where;
5195 : 1384 : gfc_set_sym_referenced (sym);
5196 : :
5197 : : /* If the selector is a inferred type then the associate_name had better
5198 : : be as well. Use array references, if present, to identify it as an
5199 : : array. */
5200 : 1384 : if (IS_INFERRED_TYPE (a->target))
5201 : : {
5202 : 18 : sym->assoc->inferred_type = 1;
5203 : 48 : for (gfc_ref *r = a->target->ref; r; r = r->next)
5204 : 30 : if (r->type == REF_ARRAY)
5205 : 18 : sym->attr.dimension = 1;
5206 : : }
5207 : :
5208 : : /* Initialize the typespec. It is not available in all cases,
5209 : : however, as it may only be set on the target during resolution.
5210 : : Still, sometimes it helps to have it right now -- especially
5211 : : for parsing component references on the associate-name
5212 : : in case of association to a derived-type. */
5213 : 1384 : sym->ts = a->target->ts;
5214 : 1384 : target = a->target;
5215 : :
5216 : : /* Don’t share the character length information between associate
5217 : : variable and target if the length is not a compile-time constant,
5218 : : as we don’t want to touch some other character length variable when
5219 : : we try to initialize the associate variable’s character length
5220 : : variable.
5221 : : We do it here rather than later so that expressions referencing the
5222 : : associate variable will automatically have the correctly setup length
5223 : : information. If we did it at resolution stage the expressions would
5224 : : use the original length information, and the variable a new different
5225 : : one, but only the latter one would be correctly initialized at
5226 : : translation stage, and the former one would need some additional setup
5227 : : there. */
5228 : 1384 : if (sym->ts.type == BT_CHARACTER
5229 : 296 : && sym->ts.u.cl
5230 : 186 : && !(sym->ts.u.cl->length
5231 : 74 : && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT))
5232 : 124 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5233 : :
5234 : : /* If the function has been parsed, go straight to the result to
5235 : : obtain the expression rank. */
5236 : 1384 : if (target->expr_type == EXPR_FUNCTION
5237 : 300 : && target->symtree
5238 : 300 : && target->symtree->n.sym)
5239 : : {
5240 : 300 : tsym = target->symtree->n.sym;
5241 : 300 : if (!tsym->result)
5242 : 0 : tsym->result = tsym;
5243 : 300 : sym->ts = tsym->result->ts;
5244 : 300 : if (sym->ts.type == BT_CLASS)
5245 : : {
5246 : 18 : if (CLASS_DATA (sym)->as)
5247 : : {
5248 : 12 : target->rank = CLASS_DATA (sym)->as->rank;
5249 : 12 : target->corank = CLASS_DATA (sym)->as->corank;
5250 : : }
5251 : 18 : sym->attr.class_ok = 1;
5252 : : }
5253 : : else
5254 : : {
5255 : 282 : target->rank = tsym->result->as ? tsym->result->as->rank : 0;
5256 : 282 : target->corank = tsym->result->as ? tsym->result->as->corank : 0;
5257 : : }
5258 : : }
5259 : :
5260 : : /* Check if the target expression is array valued. This cannot be done
5261 : : by calling gfc_resolve_expr because the context is unavailable.
5262 : : However, the references can be resolved and the rank of the target
5263 : : expression set. */
5264 : 1384 : if (!sym->assoc->inferred_type
5265 : 1366 : && target->ref && gfc_resolve_ref (target)
5266 : 556 : && target->expr_type != EXPR_ARRAY
5267 : 1940 : && target->expr_type != EXPR_COMPCALL)
5268 : 556 : gfc_expression_rank (target);
5269 : :
5270 : : /* Determine whether or not function expressions with unknown type are
5271 : : structure constructors. If so, the function result can be converted
5272 : : to be a derived type. */
5273 : 1384 : if (target->expr_type == EXPR_FUNCTION
5274 : 300 : && target->ts.type == BT_UNKNOWN)
5275 : : {
5276 : 300 : gfc_symbol *derived;
5277 : : /* The derived type has a leading uppercase character. */
5278 : 300 : gfc_find_symbol (gfc_dt_upper_string (target->symtree->name),
5279 : : my_ns->parent, 1, &derived);
5280 : 300 : if (derived && derived->attr.flavor == FL_DERIVED)
5281 : : {
5282 : 26 : sym->ts.type = BT_DERIVED;
5283 : 26 : sym->ts.u.derived = derived;
5284 : 26 : sym->assoc->inferred_type = 0;
5285 : : }
5286 : : }
5287 : :
5288 : 1384 : rank = target->rank;
5289 : 1384 : corank = target->corank;
5290 : : /* Fixup cases where the ranks are mismatched. */
5291 : 1384 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
5292 : : {
5293 : 146 : if ((!CLASS_DATA (sym)->as && (rank != 0 || corank != 0))
5294 : 146 : || (CLASS_DATA (sym)->as
5295 : 96 : && (CLASS_DATA (sym)->as->rank != rank
5296 : 76 : || CLASS_DATA (sym)->as->corank != corank))
5297 : 126 : || rank == -1)
5298 : : {
5299 : : /* Don't just (re-)set the attr and as in the sym.ts,
5300 : : because this modifies the target's attr and as. Copy the
5301 : : data and do a build_class_symbol. */
5302 : 32 : symbol_attribute attr = CLASS_DATA (target)->attr;
5303 : 32 : gfc_typespec type;
5304 : 32 : if (rank == -1 && a->ar)
5305 : : {
5306 : 12 : as = gfc_get_array_spec ();
5307 : 12 : as->rank = a->ar->dimen;
5308 : 12 : as->corank = 0;
5309 : 12 : as->type = AS_DEFERRED;
5310 : 12 : attr.dimension = rank ? 1 : 0;
5311 : 12 : attr.codimension = as->corank ? 1 : 0;
5312 : 12 : sym->assoc->variable = true;
5313 : : }
5314 : 20 : else if (rank || corank)
5315 : : {
5316 : 0 : as = gfc_get_array_spec ();
5317 : 0 : as->type = AS_DEFERRED;
5318 : 0 : as->rank = rank;
5319 : 0 : as->corank = corank;
5320 : 0 : attr.dimension = rank ? 1 : 0;
5321 : 0 : attr.codimension = corank ? 1 : 0;
5322 : : }
5323 : : else
5324 : : {
5325 : 20 : as = NULL;
5326 : 20 : attr.dimension = attr.codimension = 0;
5327 : : }
5328 : 32 : attr.class_ok = 0;
5329 : 32 : attr.associate_var = 1;
5330 : 32 : type = CLASS_DATA (sym)->ts;
5331 : 32 : if (!gfc_build_class_symbol (&type, &attr, &as))
5332 : 0 : gcc_unreachable ();
5333 : 32 : sym->ts = type;
5334 : 32 : sym->ts.type = BT_CLASS;
5335 : 32 : sym->attr.class_ok = 1;
5336 : 32 : }
5337 : : else
5338 : 114 : sym->attr.class_ok = 1;
5339 : : }
5340 : 1238 : else if (rank == -1 && a->ar)
5341 : : {
5342 : 14 : sym->as = gfc_get_array_spec ();
5343 : 14 : sym->as->rank = a->ar->dimen;
5344 : 14 : sym->as->corank = a->ar->codimen;
5345 : 14 : sym->as->type = AS_DEFERRED;
5346 : 14 : sym->attr.dimension = 1;
5347 : 14 : sym->attr.codimension = sym->as->corank ? 1 : 0;
5348 : 14 : sym->attr.pointer = 1;
5349 : : }
5350 : 1224 : else if ((!sym->as && (rank != 0 || corank != 0))
5351 : 752 : || (sym->as
5352 : 0 : && (sym->as->rank != rank || sym->as->corank != corank)))
5353 : : {
5354 : 472 : as = gfc_get_array_spec ();
5355 : 472 : as->type = AS_DEFERRED;
5356 : 472 : as->rank = rank;
5357 : 472 : as->corank = corank;
5358 : 472 : sym->as = as;
5359 : 472 : if (rank)
5360 : 463 : sym->attr.dimension = 1;
5361 : 472 : if (corank)
5362 : : {
5363 : 11 : as->cotype = AS_ASSUMED_SHAPE;
5364 : 11 : sym->attr.codimension = 1;
5365 : : }
5366 : : }
5367 : 1384 : gfc_commit_symbols ();
5368 : : }
5369 : :
5370 : 1278 : accept_statement (ST_ASSOCIATE);
5371 : 1278 : push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
5372 : :
5373 : 1279 : loop:
5374 : 1279 : st = parse_executable (ST_NONE);
5375 : 1276 : switch (st)
5376 : : {
5377 : 0 : case ST_NONE:
5378 : 0 : unexpected_eof ();
5379 : :
5380 : 1275 : case_end:
5381 : 1275 : accept_statement (st);
5382 : 1275 : my_ns->code = gfc_state_stack->head;
5383 : 1275 : break;
5384 : :
5385 : 1 : default:
5386 : 1 : unexpected_statement (st);
5387 : 1 : goto loop;
5388 : : }
5389 : :
5390 : 1275 : gfc_current_ns = gfc_current_ns->parent;
5391 : 1275 : pop_state ();
5392 : 1275 : }
5393 : :
5394 : :
5395 : : /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
5396 : : handled inside of parse_executable(), because they aren't really
5397 : : loop statements. */
5398 : :
5399 : : static void
5400 : 31200 : parse_do_block (void)
5401 : : {
5402 : 31200 : gfc_statement st;
5403 : 31200 : gfc_code *top;
5404 : 31200 : gfc_state_data s;
5405 : 31200 : gfc_symtree *stree;
5406 : 31200 : gfc_exec_op do_op;
5407 : :
5408 : 31200 : do_op = new_st.op;
5409 : 31200 : s.ext.end_do_label = new_st.label1;
5410 : :
5411 : 31200 : if (do_op == EXEC_DO_CONCURRENT)
5412 : : {
5413 : 70 : gfc_forall_iterator *fa;
5414 : 161 : for (fa = new_st.ext.forall_iterator; fa; fa = fa->next)
5415 : : {
5416 : : /* Apply unroll only to innermost loop (first control
5417 : : variable). */
5418 : 91 : if (directive_unroll != -1)
5419 : : {
5420 : 1 : fa->annot.unroll = directive_unroll;
5421 : 1 : directive_unroll = -1;
5422 : : }
5423 : 91 : if (directive_ivdep)
5424 : 1 : fa->annot.ivdep = directive_ivdep;
5425 : 91 : if (directive_vector)
5426 : 1 : fa->annot.vector = directive_vector;
5427 : 91 : if (directive_novector)
5428 : 2 : fa->annot.novector = directive_novector;
5429 : : }
5430 : 70 : directive_ivdep = false;
5431 : 70 : directive_vector = false;
5432 : 70 : directive_novector = false;
5433 : 70 : stree = NULL;
5434 : : }
5435 : 31130 : else if (new_st.ext.iterator != NULL)
5436 : : {
5437 : 30606 : stree = new_st.ext.iterator->var->symtree;
5438 : 30606 : if (directive_unroll != -1)
5439 : : {
5440 : 16 : new_st.ext.iterator->annot.unroll = directive_unroll;
5441 : 16 : directive_unroll = -1;
5442 : : }
5443 : 30606 : if (directive_ivdep)
5444 : : {
5445 : 2 : new_st.ext.iterator->annot.ivdep = directive_ivdep;
5446 : 2 : directive_ivdep = false;
5447 : : }
5448 : 30606 : if (directive_vector)
5449 : : {
5450 : 2 : new_st.ext.iterator->annot.vector = directive_vector;
5451 : 2 : directive_vector = false;
5452 : : }
5453 : 30606 : if (directive_novector)
5454 : : {
5455 : 2 : new_st.ext.iterator->annot.novector = directive_novector;
5456 : 2 : directive_novector = false;
5457 : : }
5458 : : }
5459 : : else
5460 : : stree = NULL;
5461 : :
5462 : 31200 : accept_statement (ST_DO);
5463 : :
5464 : 31200 : top = gfc_state_stack->tail;
5465 : 62330 : push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
5466 : : gfc_new_block);
5467 : :
5468 : 31200 : s.do_variable = stree;
5469 : :
5470 : 31200 : top->block = new_level (top);
5471 : 31200 : top->block->op = EXEC_DO;
5472 : :
5473 : 31201 : loop:
5474 : 31201 : st = parse_executable (ST_NONE);
5475 : :
5476 : 31199 : switch (st)
5477 : : {
5478 : 0 : case ST_NONE:
5479 : 0 : unexpected_eof ();
5480 : :
5481 : 29047 : case ST_ENDDO:
5482 : 29047 : if (s.ext.end_do_label != NULL
5483 : 86 : && s.ext.end_do_label != gfc_statement_label)
5484 : 1 : gfc_error_now ("Statement label in ENDDO at %C doesn't match "
5485 : : "DO label");
5486 : :
5487 : 29047 : if (gfc_statement_label != NULL)
5488 : : {
5489 : 98 : new_st.op = EXEC_NOP;
5490 : 98 : add_statement ();
5491 : : }
5492 : : break;
5493 : :
5494 : 2151 : case ST_IMPLIED_ENDDO:
5495 : : /* If the do-stmt of this DO construct has a do-construct-name,
5496 : : the corresponding end-do must be an end-do-stmt (with a matching
5497 : : name, but in that case we must have seen ST_ENDDO first).
5498 : : We only complain about this in pedantic mode. */
5499 : 2151 : if (gfc_current_block () != NULL)
5500 : 1 : gfc_error_now ("Named block DO at %L requires matching ENDDO name",
5501 : : &gfc_current_block()->declared_at);
5502 : :
5503 : : break;
5504 : :
5505 : 1 : default:
5506 : 1 : unexpected_statement (st);
5507 : 1 : goto loop;
5508 : : }
5509 : :
5510 : 31198 : pop_state ();
5511 : 31198 : accept_statement (st);
5512 : 31198 : }
5513 : :
5514 : :
5515 : : /* Parse the statements of OpenMP do/parallel do. */
5516 : :
5517 : : static gfc_statement
5518 : 5130 : parse_omp_do (gfc_statement omp_st, int nested)
5519 : : {
5520 : 5130 : gfc_statement st;
5521 : 5130 : gfc_code *cp, *np;
5522 : 5130 : gfc_state_data s;
5523 : :
5524 : 5130 : accept_statement (omp_st);
5525 : :
5526 : 5130 : cp = gfc_state_stack->tail;
5527 : 5130 : push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5528 : 5130 : np = new_level (cp);
5529 : 5130 : np->op = cp->op;
5530 : 5130 : np->block = NULL;
5531 : :
5532 : 5212 : for (;;)
5533 : : {
5534 : 5171 : st = next_statement ();
5535 : 5171 : if (st == ST_NONE)
5536 : 2 : unexpected_eof ();
5537 : 5169 : else if (st == ST_DO)
5538 : : break;
5539 : 389 : else if (st == ST_OMP_UNROLL || st == ST_OMP_TILE)
5540 : : {
5541 : 348 : st = parse_omp_do (st, nested + 1);
5542 : 348 : if (st == ST_IMPLIED_ENDDO)
5543 : : return st;
5544 : 348 : goto do_end;
5545 : : }
5546 : : else
5547 : 41 : unexpected_statement (st);
5548 : : }
5549 : :
5550 : 4780 : parse_do_block ();
5551 : 9908 : for (; nested; --nested)
5552 : 348 : pop_state ();
5553 : 4780 : if (gfc_statement_label != NULL
5554 : 59 : && gfc_state_stack->previous != NULL
5555 : 59 : && gfc_state_stack->previous->state == COMP_DO
5556 : 2 : && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
5557 : : {
5558 : : /* In
5559 : : DO 100 I=1,10
5560 : : !$OMP DO
5561 : : DO J=1,10
5562 : : ...
5563 : : 100 CONTINUE
5564 : : there should be no !$OMP END DO. */
5565 : 2 : pop_state ();
5566 : 2 : return ST_IMPLIED_ENDDO;
5567 : : }
5568 : :
5569 : 4778 : check_do_closure ();
5570 : 4778 : pop_state ();
5571 : :
5572 : 4778 : st = next_statement ();
5573 : 5126 : do_end:
5574 : 5126 : gfc_statement omp_end_st = ST_OMP_END_DO;
5575 : 5126 : switch (omp_st)
5576 : : {
5577 : : case ST_OMP_DISTRIBUTE: omp_end_st = ST_OMP_END_DISTRIBUTE; break;
5578 : 36 : case ST_OMP_DISTRIBUTE_PARALLEL_DO:
5579 : 36 : omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
5580 : 36 : break;
5581 : 33 : case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5582 : 33 : omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
5583 : 33 : break;
5584 : 51 : case ST_OMP_DISTRIBUTE_SIMD:
5585 : 51 : omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
5586 : 51 : break;
5587 : 1202 : case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break;
5588 : 134 : case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break;
5589 : 64 : case ST_OMP_LOOP: omp_end_st = ST_OMP_END_LOOP; break;
5590 : 1157 : case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break;
5591 : 289 : case ST_OMP_PARALLEL_DO_SIMD:
5592 : 289 : omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD;
5593 : 289 : break;
5594 : 15 : case ST_OMP_PARALLEL_LOOP:
5595 : 15 : omp_end_st = ST_OMP_END_PARALLEL_LOOP;
5596 : 15 : break;
5597 : 781 : case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break;
5598 : 68 : case ST_OMP_TARGET_PARALLEL_DO:
5599 : 68 : omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO;
5600 : 68 : break;
5601 : 19 : case ST_OMP_TARGET_PARALLEL_DO_SIMD:
5602 : 19 : omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO_SIMD;
5603 : 19 : break;
5604 : 16 : case ST_OMP_TARGET_PARALLEL_LOOP:
5605 : 16 : omp_end_st = ST_OMP_END_TARGET_PARALLEL_LOOP;
5606 : 16 : break;
5607 : 33 : case ST_OMP_TARGET_SIMD: omp_end_st = ST_OMP_END_TARGET_SIMD; break;
5608 : 18 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
5609 : 18 : omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
5610 : 18 : break;
5611 : 53 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5612 : 53 : omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
5613 : 53 : break;
5614 : 33 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5615 : 33 : omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
5616 : 33 : break;
5617 : 20 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5618 : 20 : omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
5619 : 20 : break;
5620 : 17 : case ST_OMP_TARGET_TEAMS_LOOP:
5621 : 17 : omp_end_st = ST_OMP_END_TARGET_TEAMS_LOOP;
5622 : 17 : break;
5623 : 90 : case ST_OMP_TASKLOOP: omp_end_st = ST_OMP_END_TASKLOOP; break;
5624 : 39 : case ST_OMP_TASKLOOP_SIMD: omp_end_st = ST_OMP_END_TASKLOOP_SIMD; break;
5625 : 9 : case ST_OMP_MASKED_TASKLOOP: omp_end_st = ST_OMP_END_MASKED_TASKLOOP; break;
5626 : 14 : case ST_OMP_MASKED_TASKLOOP_SIMD:
5627 : 14 : omp_end_st = ST_OMP_END_MASKED_TASKLOOP_SIMD;
5628 : 14 : break;
5629 : 15 : case ST_OMP_MASTER_TASKLOOP: omp_end_st = ST_OMP_END_MASTER_TASKLOOP; break;
5630 : 21 : case ST_OMP_MASTER_TASKLOOP_SIMD:
5631 : 21 : omp_end_st = ST_OMP_END_MASTER_TASKLOOP_SIMD;
5632 : 21 : break;
5633 : 8 : case ST_OMP_PARALLEL_MASKED_TASKLOOP:
5634 : 8 : omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP;
5635 : 8 : break;
5636 : 11 : case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
5637 : 11 : omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD;
5638 : 11 : break;
5639 : 13 : case ST_OMP_PARALLEL_MASTER_TASKLOOP:
5640 : 13 : omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP;
5641 : 13 : break;
5642 : 19 : case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
5643 : 19 : omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD;
5644 : 19 : break;
5645 : 21 : case ST_OMP_TEAMS_DISTRIBUTE:
5646 : 21 : omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
5647 : 21 : break;
5648 : 38 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5649 : 38 : omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
5650 : 38 : break;
5651 : 61 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5652 : 61 : omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
5653 : 61 : break;
5654 : 43 : case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
5655 : 43 : omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
5656 : 43 : break;
5657 : 12 : case ST_OMP_TEAMS_LOOP: omp_end_st = ST_OMP_END_TEAMS_LOOP; break;
5658 : 195 : case ST_OMP_TILE: omp_end_st = ST_OMP_END_TILE; break;
5659 : 423 : case ST_OMP_UNROLL: omp_end_st = ST_OMP_END_UNROLL; break;
5660 : 0 : default: gcc_unreachable ();
5661 : : }
5662 : 5126 : if (st == omp_end_st)
5663 : : {
5664 : 863 : if (new_st.op == EXEC_OMP_END_NOWAIT)
5665 : : {
5666 : 381 : if (cp->ext.omp_clauses->nowait && new_st.ext.omp_bool)
5667 : 11 : gfc_error_now ("Duplicated NOWAIT clause on %s and %s at %C",
5668 : : gfc_ascii_statement (omp_st),
5669 : : gfc_ascii_statement (omp_end_st));
5670 : 381 : cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
5671 : : }
5672 : : else
5673 : 482 : gcc_assert (new_st.op == EXEC_NOP);
5674 : 863 : gfc_clear_new_st ();
5675 : 863 : gfc_commit_symbols ();
5676 : 863 : gfc_warning_check ();
5677 : 863 : st = next_statement ();
5678 : : }
5679 : : return st;
5680 : : }
5681 : :
5682 : :
5683 : : /* Parse the statements of OpenMP atomic directive. */
5684 : :
5685 : : static gfc_statement
5686 : 2708 : parse_omp_oacc_atomic (bool omp_p)
5687 : : {
5688 : 2708 : gfc_statement st, st_atomic, st_end_atomic;
5689 : 2708 : gfc_code *cp, *np;
5690 : 2708 : gfc_state_data s;
5691 : 2708 : int count;
5692 : :
5693 : 2708 : if (omp_p)
5694 : : {
5695 : : st_atomic = ST_OMP_ATOMIC;
5696 : : st_end_atomic = ST_OMP_END_ATOMIC;
5697 : : }
5698 : : else
5699 : : {
5700 : 543 : st_atomic = ST_OACC_ATOMIC;
5701 : 543 : st_end_atomic = ST_OACC_END_ATOMIC;
5702 : : }
5703 : 2708 : accept_statement (st_atomic);
5704 : :
5705 : 2708 : cp = gfc_state_stack->tail;
5706 : 2708 : push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5707 : 2708 : np = new_level (cp);
5708 : 2708 : np->op = cp->op;
5709 : 2708 : np->block = NULL;
5710 : 2708 : np->ext.omp_clauses = cp->ext.omp_clauses;
5711 : 2708 : cp->ext.omp_clauses = NULL;
5712 : 2708 : count = 1 + np->ext.omp_clauses->capture;
5713 : :
5714 : 5958 : while (count)
5715 : : {
5716 : 3250 : st = next_statement ();
5717 : 3250 : if (st == ST_NONE)
5718 : 0 : unexpected_eof ();
5719 : 3250 : else if (np->ext.omp_clauses->compare
5720 : 194 : && (st == ST_SIMPLE_IF || st == ST_IF_BLOCK))
5721 : : {
5722 : 156 : count--;
5723 : 156 : if (st == ST_IF_BLOCK)
5724 : : {
5725 : 68 : parse_if_block ();
5726 : : /* With else (or elseif). */
5727 : 68 : if (gfc_state_stack->tail->block->block)
5728 : 65 : count--;
5729 : : }
5730 : 156 : accept_statement (st);
5731 : : }
5732 : 3094 : else if (st == ST_ASSIGNMENT
5733 : 3093 : && (!np->ext.omp_clauses->compare
5734 : 3093 : || np->ext.omp_clauses->capture))
5735 : : {
5736 : 3093 : accept_statement (st);
5737 : 3093 : count--;
5738 : : }
5739 : : else
5740 : 1 : unexpected_statement (st);
5741 : : }
5742 : :
5743 : 2708 : pop_state ();
5744 : :
5745 : 2708 : st = next_statement ();
5746 : 2708 : if (st == st_end_atomic)
5747 : : {
5748 : 743 : gfc_clear_new_st ();
5749 : 743 : gfc_commit_symbols ();
5750 : 743 : gfc_warning_check ();
5751 : 743 : st = next_statement ();
5752 : : }
5753 : 2708 : return st;
5754 : : }
5755 : :
5756 : :
5757 : : /* Parse the statements of an OpenACC structured block. */
5758 : :
5759 : : static void
5760 : 4534 : parse_oacc_structured_block (gfc_statement acc_st)
5761 : : {
5762 : 4534 : gfc_statement st, acc_end_st;
5763 : 4534 : gfc_code *cp, *np;
5764 : 4534 : gfc_state_data s, *sd;
5765 : :
5766 : 15558 : for (sd = gfc_state_stack; sd; sd = sd->previous)
5767 : 11024 : if (sd->state == COMP_CRITICAL)
5768 : 1 : gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5769 : :
5770 : 4534 : accept_statement (acc_st);
5771 : :
5772 : 4534 : cp = gfc_state_stack->tail;
5773 : 4534 : push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5774 : 4534 : np = new_level (cp);
5775 : 4534 : np->op = cp->op;
5776 : 4534 : np->block = NULL;
5777 : 4534 : switch (acc_st)
5778 : : {
5779 : : case ST_OACC_PARALLEL:
5780 : 4534 : acc_end_st = ST_OACC_END_PARALLEL;
5781 : : break;
5782 : 865 : case ST_OACC_KERNELS:
5783 : 865 : acc_end_st = ST_OACC_END_KERNELS;
5784 : 865 : break;
5785 : 66 : case ST_OACC_SERIAL:
5786 : 66 : acc_end_st = ST_OACC_END_SERIAL;
5787 : 66 : break;
5788 : 648 : case ST_OACC_DATA:
5789 : 648 : acc_end_st = ST_OACC_END_DATA;
5790 : 648 : break;
5791 : 60 : case ST_OACC_HOST_DATA:
5792 : 60 : acc_end_st = ST_OACC_END_HOST_DATA;
5793 : 60 : break;
5794 : 0 : default:
5795 : 0 : gcc_unreachable ();
5796 : : }
5797 : :
5798 : 4534 : do
5799 : : {
5800 : 4534 : st = parse_executable (ST_NONE);
5801 : 4534 : if (st == ST_NONE)
5802 : : unexpected_eof ();
5803 : 4534 : else if (st != acc_end_st)
5804 : : {
5805 : 0 : gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st));
5806 : 0 : reject_statement ();
5807 : : }
5808 : : }
5809 : 4534 : while (st != acc_end_st);
5810 : :
5811 : 4534 : gcc_assert (new_st.op == EXEC_NOP);
5812 : :
5813 : 4534 : gfc_clear_new_st ();
5814 : 4534 : gfc_commit_symbols ();
5815 : 4534 : gfc_warning_check ();
5816 : 4534 : pop_state ();
5817 : 4534 : }
5818 : :
5819 : : /* Parse the statements of OpenACC 'loop', or combined compute 'loop'. */
5820 : :
5821 : : static gfc_statement
5822 : 4739 : parse_oacc_loop (gfc_statement acc_st)
5823 : : {
5824 : 4739 : gfc_statement st;
5825 : 4739 : gfc_code *cp, *np;
5826 : 4739 : gfc_state_data s, *sd;
5827 : :
5828 : 21580 : for (sd = gfc_state_stack; sd; sd = sd->previous)
5829 : 16841 : if (sd->state == COMP_CRITICAL)
5830 : 0 : gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5831 : :
5832 : 4739 : accept_statement (acc_st);
5833 : :
5834 : 4739 : cp = gfc_state_stack->tail;
5835 : 4739 : push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5836 : 4739 : np = new_level (cp);
5837 : 4739 : np->op = cp->op;
5838 : 4739 : np->block = NULL;
5839 : :
5840 : 4745 : for (;;)
5841 : : {
5842 : 4742 : st = next_statement ();
5843 : 4742 : if (st == ST_NONE)
5844 : 0 : unexpected_eof ();
5845 : 4742 : else if (st == ST_DO)
5846 : : break;
5847 : : else
5848 : : {
5849 : 3 : gfc_error ("Expected DO loop at %C");
5850 : 3 : reject_statement ();
5851 : : }
5852 : : }
5853 : :
5854 : 4739 : parse_do_block ();
5855 : 4739 : if (gfc_statement_label != NULL
5856 : 80 : && gfc_state_stack->previous != NULL
5857 : 80 : && gfc_state_stack->previous->state == COMP_DO
5858 : 0 : && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
5859 : : {
5860 : 0 : pop_state ();
5861 : 0 : return ST_IMPLIED_ENDDO;
5862 : : }
5863 : :
5864 : 4739 : check_do_closure ();
5865 : 4739 : pop_state ();
5866 : :
5867 : 4739 : st = next_statement ();
5868 : 4739 : if (st == ST_OACC_END_LOOP)
5869 : 2 : gfc_warning (0, "Redundant !$ACC END LOOP at %C");
5870 : 4739 : if ((acc_st == ST_OACC_PARALLEL_LOOP && st == ST_OACC_END_PARALLEL_LOOP) ||
5871 : 3813 : (acc_st == ST_OACC_KERNELS_LOOP && st == ST_OACC_END_KERNELS_LOOP) ||
5872 : 3791 : (acc_st == ST_OACC_SERIAL_LOOP && st == ST_OACC_END_SERIAL_LOOP) ||
5873 : 3788 : (acc_st == ST_OACC_LOOP && st == ST_OACC_END_LOOP))
5874 : : {
5875 : 953 : gcc_assert (new_st.op == EXEC_NOP);
5876 : 953 : gfc_clear_new_st ();
5877 : 953 : gfc_commit_symbols ();
5878 : 953 : gfc_warning_check ();
5879 : 953 : st = next_statement ();
5880 : : }
5881 : : return st;
5882 : : }
5883 : :
5884 : :
5885 : : /* Parse an OpenMP allocate block, including optional ALLOCATORS
5886 : : end directive. */
5887 : :
5888 : : static gfc_statement
5889 : 70 : parse_openmp_allocate_block (gfc_statement omp_st)
5890 : : {
5891 : 70 : gfc_statement st;
5892 : 70 : gfc_code *cp, *np;
5893 : 70 : gfc_state_data s;
5894 : 70 : bool empty_list = false;
5895 : 70 : locus empty_list_loc;
5896 : 70 : gfc_omp_namelist *n_first = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
5897 : :
5898 : 70 : if (omp_st == ST_OMP_ALLOCATE_EXEC
5899 : 47 : && new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym == NULL)
5900 : : {
5901 : 23 : empty_list = true;
5902 : 23 : empty_list_loc = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
5903 : : }
5904 : :
5905 : 70 : accept_statement (omp_st);
5906 : :
5907 : 70 : cp = gfc_state_stack->tail;
5908 : 70 : push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5909 : 70 : np = new_level (cp);
5910 : 70 : np->op = cp->op;
5911 : 70 : np->block = NULL;
5912 : :
5913 : 70 : st = next_statement ();
5914 : 153 : while (omp_st == ST_OMP_ALLOCATE_EXEC && st == ST_OMP_ALLOCATE_EXEC)
5915 : : {
5916 : 13 : if (empty_list && !new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym)
5917 : : {
5918 : 1 : locus *loc = &new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
5919 : 1 : gfc_error_now ("%s statements at %L and %L have both no list item but"
5920 : : " only one may", gfc_ascii_statement (st),
5921 : : &empty_list_loc, loc);
5922 : 1 : empty_list = false;
5923 : : }
5924 : 13 : if (!new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym)
5925 : : {
5926 : 3 : empty_list = true;
5927 : 3 : empty_list_loc = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
5928 : : }
5929 : 22 : for ( ; n_first->next; n_first = n_first->next)
5930 : : ;
5931 : 13 : n_first->next = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
5932 : 13 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = NULL;
5933 : 13 : gfc_free_omp_clauses (new_st.ext.omp_clauses);
5934 : :
5935 : 13 : accept_statement (ST_NONE);
5936 : 13 : st = next_statement ();
5937 : : }
5938 : 70 : if (st != ST_ALLOCATE && omp_st == ST_OMP_ALLOCATE_EXEC)
5939 : 1 : gfc_error_now ("Unexpected %s at %C; expected ALLOCATE or %s statement",
5940 : : gfc_ascii_statement (st), gfc_ascii_statement (omp_st));
5941 : 69 : else if (st != ST_ALLOCATE)
5942 : 3 : gfc_error_now ("Unexpected %s at %C; expected ALLOCATE statement after %s",
5943 : : gfc_ascii_statement (st), gfc_ascii_statement (omp_st));
5944 : 70 : accept_statement (st);
5945 : 70 : pop_state ();
5946 : 70 : st = next_statement ();
5947 : 70 : if (omp_st == ST_OMP_ALLOCATORS && st == ST_OMP_END_ALLOCATORS)
5948 : : {
5949 : 4 : accept_statement (st);
5950 : 4 : st = next_statement ();
5951 : : }
5952 : 70 : return st;
5953 : : }
5954 : :
5955 : :
5956 : : /* Parse the statements of an OpenMP structured block. */
5957 : :
5958 : : static gfc_statement
5959 : 8154 : parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
5960 : : {
5961 : 8154 : gfc_statement st, omp_end_st, first_st;
5962 : 8154 : gfc_code *cp, *np;
5963 : 8154 : gfc_state_data s, s2;
5964 : :
5965 : 8154 : accept_statement (omp_st);
5966 : :
5967 : 8154 : cp = gfc_state_stack->tail;
5968 : 8154 : push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5969 : 8154 : np = new_level (cp);
5970 : 8154 : np->op = cp->op;
5971 : 8154 : np->block = NULL;
5972 : :
5973 : 8154 : switch (omp_st)
5974 : : {
5975 : : case ST_OMP_ASSUME:
5976 : : omp_end_st = ST_OMP_END_ASSUME;
5977 : : break;
5978 : 2074 : case ST_OMP_PARALLEL:
5979 : 2074 : omp_end_st = ST_OMP_END_PARALLEL;
5980 : 2074 : break;
5981 : 13 : case ST_OMP_PARALLEL_MASKED:
5982 : 13 : omp_end_st = ST_OMP_END_PARALLEL_MASKED;
5983 : 13 : break;
5984 : 13 : case ST_OMP_PARALLEL_MASTER:
5985 : 13 : omp_end_st = ST_OMP_END_PARALLEL_MASTER;
5986 : 13 : break;
5987 : 58 : case ST_OMP_PARALLEL_SECTIONS:
5988 : 58 : omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
5989 : 58 : break;
5990 : 58 : case ST_OMP_SCOPE:
5991 : 58 : omp_end_st = ST_OMP_END_SCOPE;
5992 : 58 : break;
5993 : 82 : case ST_OMP_SECTIONS:
5994 : 82 : omp_end_st = ST_OMP_END_SECTIONS;
5995 : 82 : break;
5996 : 234 : case ST_OMP_ORDERED:
5997 : 234 : omp_end_st = ST_OMP_END_ORDERED;
5998 : 234 : break;
5999 : 160 : case ST_OMP_CRITICAL:
6000 : 160 : omp_end_st = ST_OMP_END_CRITICAL;
6001 : 160 : break;
6002 : 47 : case ST_OMP_MASKED:
6003 : 47 : omp_end_st = ST_OMP_END_MASKED;
6004 : 47 : break;
6005 : 109 : case ST_OMP_MASTER:
6006 : 109 : omp_end_st = ST_OMP_END_MASTER;
6007 : 109 : break;
6008 : 579 : case ST_OMP_SINGLE:
6009 : 579 : omp_end_st = ST_OMP_END_SINGLE;
6010 : 579 : break;
6011 : 1645 : case ST_OMP_TARGET:
6012 : 1645 : omp_end_st = ST_OMP_END_TARGET;
6013 : 1645 : break;
6014 : 1397 : case ST_OMP_TARGET_DATA:
6015 : 1397 : omp_end_st = ST_OMP_END_TARGET_DATA;
6016 : 1397 : break;
6017 : 24 : case ST_OMP_TARGET_PARALLEL:
6018 : 24 : omp_end_st = ST_OMP_END_TARGET_PARALLEL;
6019 : 24 : break;
6020 : 66 : case ST_OMP_TARGET_TEAMS:
6021 : 66 : omp_end_st = ST_OMP_END_TARGET_TEAMS;
6022 : 66 : break;
6023 : 1153 : case ST_OMP_TASK:
6024 : 1153 : omp_end_st = ST_OMP_END_TASK;
6025 : 1153 : break;
6026 : 187 : case ST_OMP_TASKGROUP:
6027 : 187 : omp_end_st = ST_OMP_END_TASKGROUP;
6028 : 187 : break;
6029 : 146 : case ST_OMP_TEAMS:
6030 : 146 : omp_end_st = ST_OMP_END_TEAMS;
6031 : 146 : break;
6032 : 0 : case ST_OMP_TEAMS_DISTRIBUTE:
6033 : 0 : omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
6034 : 0 : break;
6035 : 0 : case ST_OMP_DISTRIBUTE:
6036 : 0 : omp_end_st = ST_OMP_END_DISTRIBUTE;
6037 : 0 : break;
6038 : 39 : case ST_OMP_WORKSHARE:
6039 : 39 : omp_end_st = ST_OMP_END_WORKSHARE;
6040 : 39 : break;
6041 : 55 : case ST_OMP_PARALLEL_WORKSHARE:
6042 : 55 : omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
6043 : 55 : break;
6044 : 0 : default:
6045 : 0 : gcc_unreachable ();
6046 : : }
6047 : :
6048 : 8154 : bool block_construct = false;
6049 : 8154 : gfc_namespace *my_ns = NULL;
6050 : 8154 : gfc_namespace *my_parent = NULL;
6051 : :
6052 : 8154 : first_st = st = next_statement ();
6053 : :
6054 : 8154 : if (st == ST_BLOCK)
6055 : : {
6056 : : /* Adjust state to a strictly-structured block, now that we found that
6057 : : the body starts with a BLOCK construct. */
6058 : 338 : s.state = COMP_OMP_STRICTLY_STRUCTURED_BLOCK;
6059 : :
6060 : 338 : block_construct = true;
6061 : 338 : gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
6062 : :
6063 : 338 : my_ns = gfc_build_block_ns (gfc_current_ns);
6064 : 338 : new_st.op = EXEC_BLOCK;
6065 : 338 : new_st.ext.block.ns = my_ns;
6066 : 338 : new_st.ext.block.assoc = NULL;
6067 : 338 : accept_statement (ST_BLOCK);
6068 : :
6069 : 338 : push_state (&s2, COMP_BLOCK, my_ns->proc_name);
6070 : 338 : gfc_current_ns = my_ns;
6071 : 338 : my_parent = my_ns->parent;
6072 : 338 : if (omp_st == ST_OMP_SECTIONS
6073 : 338 : || omp_st == ST_OMP_PARALLEL_SECTIONS)
6074 : : {
6075 : 2 : np = new_level (cp);
6076 : 2 : np->op = cp->op;
6077 : : }
6078 : :
6079 : 338 : first_st = next_statement ();
6080 : 338 : st = parse_spec (first_st);
6081 : : }
6082 : :
6083 : 8154 : if (omp_end_st == ST_OMP_END_TARGET)
6084 : 1645 : switch (first_st)
6085 : : {
6086 : 174 : case ST_OMP_TEAMS:
6087 : 174 : case ST_OMP_TEAMS_DISTRIBUTE:
6088 : 174 : case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
6089 : 174 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
6090 : 174 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6091 : 174 : case ST_OMP_TEAMS_LOOP:
6092 : 174 : {
6093 : 174 : gfc_state_data *stk = gfc_state_stack->previous;
6094 : 174 : if (stk->state == COMP_OMP_STRICTLY_STRUCTURED_BLOCK)
6095 : 6 : stk = stk->previous;
6096 : 174 : stk->tail->ext.omp_clauses->target_first_st_is_teams = true;
6097 : 174 : break;
6098 : : }
6099 : : default:
6100 : : break;
6101 : : }
6102 : :
6103 : 8393 : do
6104 : : {
6105 : 8393 : if (workshare_stmts_only)
6106 : : {
6107 : : /* Inside of !$omp workshare, only
6108 : : scalar assignments
6109 : : array assignments
6110 : : where statements and constructs
6111 : : forall statements and constructs
6112 : : !$omp atomic
6113 : : !$omp critical
6114 : : !$omp parallel
6115 : : are allowed. For !$omp critical these
6116 : : restrictions apply recursively. */
6117 : : bool cycle = true;
6118 : :
6119 : 339 : for (;;)
6120 : : {
6121 : 339 : switch (st)
6122 : : {
6123 : 0 : case ST_NONE:
6124 : 0 : unexpected_eof ();
6125 : :
6126 : 175 : case ST_ASSIGNMENT:
6127 : 175 : case ST_WHERE:
6128 : 175 : case ST_FORALL:
6129 : 175 : accept_statement (st);
6130 : 175 : break;
6131 : :
6132 : 6 : case ST_WHERE_BLOCK:
6133 : 6 : parse_where_block ();
6134 : 6 : break;
6135 : :
6136 : 12 : case ST_FORALL_BLOCK:
6137 : 12 : parse_forall_block ();
6138 : 12 : break;
6139 : :
6140 : 0 : case ST_OMP_ALLOCATE_EXEC:
6141 : 0 : case ST_OMP_ALLOCATORS:
6142 : 0 : st = parse_openmp_allocate_block (st);
6143 : 0 : continue;
6144 : :
6145 : 13 : case ST_OMP_ASSUME:
6146 : 13 : case ST_OMP_PARALLEL:
6147 : 13 : case ST_OMP_PARALLEL_MASKED:
6148 : 13 : case ST_OMP_PARALLEL_MASTER:
6149 : 13 : case ST_OMP_PARALLEL_SECTIONS:
6150 : 13 : st = parse_omp_structured_block (st, false);
6151 : 12 : continue;
6152 : :
6153 : 14 : case ST_OMP_PARALLEL_WORKSHARE:
6154 : 14 : case ST_OMP_CRITICAL:
6155 : 14 : st = parse_omp_structured_block (st, true);
6156 : 14 : continue;
6157 : :
6158 : 3 : case ST_OMP_PARALLEL_DO:
6159 : 3 : case ST_OMP_PARALLEL_DO_SIMD:
6160 : 3 : st = parse_omp_do (st, 0);
6161 : 3 : continue;
6162 : :
6163 : 8 : case ST_OMP_ATOMIC:
6164 : 8 : st = parse_omp_oacc_atomic (true);
6165 : 8 : continue;
6166 : :
6167 : : default:
6168 : : cycle = false;
6169 : : break;
6170 : : }
6171 : :
6172 : 193 : if (!cycle)
6173 : : break;
6174 : :
6175 : 193 : st = next_statement ();
6176 : : }
6177 : : }
6178 : : else
6179 : 8284 : st = parse_executable (st);
6180 : 8284 : if (st == ST_NONE)
6181 : : unexpected_eof ();
6182 : 8378 : else if (st == ST_OMP_SECTION
6183 : 257 : && (omp_st == ST_OMP_SECTIONS
6184 : 257 : || omp_st == ST_OMP_PARALLEL_SECTIONS))
6185 : : {
6186 : 257 : np = new_level (np);
6187 : 257 : np->op = cp->op;
6188 : 257 : np->block = NULL;
6189 : 257 : st = next_statement ();
6190 : : }
6191 : 8121 : else if (block_construct && st == ST_END_BLOCK)
6192 : : {
6193 : 338 : accept_statement (st);
6194 : 338 : gfc_current_ns->code = gfc_state_stack->head;
6195 : 338 : gfc_current_ns = my_parent;
6196 : 338 : pop_state (); /* Inner BLOCK */
6197 : 338 : pop_state (); /* Outer COMP_OMP_STRICTLY_STRUCTURED_BLOCK */
6198 : :
6199 : 338 : st = next_statement ();
6200 : 338 : if (st == omp_end_st)
6201 : : {
6202 : 110 : accept_statement (st);
6203 : 110 : st = next_statement ();
6204 : : }
6205 : 338 : return st;
6206 : : }
6207 : 7783 : else if (st != omp_end_st || block_construct)
6208 : : {
6209 : 3 : unexpected_statement (st);
6210 : 3 : st = next_statement ();
6211 : : }
6212 : : }
6213 : 8040 : while (st != omp_end_st);
6214 : :
6215 : 7801 : switch (new_st.op)
6216 : : {
6217 : 1772 : case EXEC_OMP_END_NOWAIT:
6218 : 1772 : if (cp->ext.omp_clauses->nowait && new_st.ext.omp_bool)
6219 : 6 : gfc_error_now ("Duplicated NOWAIT clause on %s and %s at %C",
6220 : : gfc_ascii_statement (omp_st),
6221 : : gfc_ascii_statement (omp_end_st));
6222 : 1772 : cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
6223 : 1772 : break;
6224 : 150 : case EXEC_OMP_END_CRITICAL:
6225 : 150 : if (((cp->ext.omp_clauses->critical_name == NULL)
6226 : 150 : ^ (new_st.ext.omp_name == NULL))
6227 : 150 : || (new_st.ext.omp_name != NULL
6228 : 44 : && strcmp (cp->ext.omp_clauses->critical_name,
6229 : : new_st.ext.omp_name) != 0))
6230 : 0 : gfc_error ("Name after !$omp critical and !$omp end critical does "
6231 : : "not match at %C");
6232 : 150 : free (CONST_CAST (char *, new_st.ext.omp_name));
6233 : 150 : new_st.ext.omp_name = NULL;
6234 : 150 : break;
6235 : 546 : case EXEC_OMP_END_SINGLE:
6236 : 546 : if (cp->ext.omp_clauses->nowait && new_st.ext.omp_clauses->nowait)
6237 : 1 : gfc_error_now ("Duplicated NOWAIT clause on %s and %s at %C",
6238 : : gfc_ascii_statement (omp_st),
6239 : : gfc_ascii_statement (omp_end_st));
6240 : 546 : cp->ext.omp_clauses->nowait |= new_st.ext.omp_clauses->nowait;
6241 : 546 : if (cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE])
6242 : : {
6243 : : gfc_omp_namelist *nl;
6244 : : for (nl = cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
6245 : 5 : nl->next; nl = nl->next)
6246 : : ;
6247 : 5 : nl->next = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
6248 : : }
6249 : : else
6250 : 541 : cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
6251 : 541 : = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
6252 : 546 : new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
6253 : 546 : gfc_free_omp_clauses (new_st.ext.omp_clauses);
6254 : 546 : break;
6255 : : case EXEC_NOP:
6256 : : break;
6257 : 0 : default:
6258 : 0 : gcc_unreachable ();
6259 : : }
6260 : :
6261 : 7801 : gfc_clear_new_st ();
6262 : 7801 : gfc_commit_symbols ();
6263 : 7801 : gfc_warning_check ();
6264 : 7801 : pop_state ();
6265 : 7801 : st = next_statement ();
6266 : 7801 : return st;
6267 : : }
6268 : :
6269 : :
6270 : : static gfc_statement
6271 : 77 : parse_omp_dispatch (void)
6272 : : {
6273 : 77 : gfc_statement st;
6274 : 77 : gfc_code *cp, *np;
6275 : 77 : gfc_state_data s;
6276 : :
6277 : 77 : accept_statement (ST_OMP_DISPATCH);
6278 : :
6279 : 77 : cp = gfc_state_stack->tail;
6280 : 77 : push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
6281 : 77 : np = new_level (cp);
6282 : 77 : np->op = cp->op;
6283 : 77 : np->block = NULL;
6284 : :
6285 : 77 : st = next_statement ();
6286 : 77 : if (st == ST_NONE)
6287 : : return st;
6288 : 76 : if (st == ST_CALL || st == ST_ASSIGNMENT)
6289 : 73 : accept_statement (st);
6290 : : else
6291 : : {
6292 : 3 : gfc_error ("%<OMP DISPATCH%> directive must be followed by a procedure "
6293 : : "call with optional assignment at %C");
6294 : 3 : reject_statement ();
6295 : : }
6296 : 76 : pop_state ();
6297 : 76 : st = next_statement ();
6298 : 76 : if (st == ST_OMP_END_DISPATCH)
6299 : : {
6300 : 5 : if (cp->ext.omp_clauses->nowait && new_st.ext.omp_bool)
6301 : 1 : gfc_error_now ("Duplicated NOWAIT clause on !$OMP DISPATCH and !$OMP "
6302 : : "END DISPATCH at %C");
6303 : 5 : cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
6304 : 5 : accept_statement (st);
6305 : 5 : st = next_statement ();
6306 : : }
6307 : : return st;
6308 : : }
6309 : :
6310 : : /* Accept a series of executable statements. We return the first
6311 : : statement that doesn't fit to the caller. Any block statements are
6312 : : passed on to the correct handler, which usually passes the buck
6313 : : right back here. */
6314 : :
6315 : : static gfc_statement
6316 : 143528 : parse_executable (gfc_statement st)
6317 : : {
6318 : 143528 : int close_flag;
6319 : 143528 : in_exec_part = true;
6320 : :
6321 : 143528 : if (st == ST_NONE)
6322 : 66030 : st = next_statement ();
6323 : :
6324 : 745672 : for (;;)
6325 : : {
6326 : 745672 : close_flag = check_do_closure ();
6327 : 745672 : if (close_flag)
6328 : 1696 : switch (st)
6329 : : {
6330 : 0 : case ST_GOTO:
6331 : 0 : case ST_END_PROGRAM:
6332 : 0 : case ST_RETURN:
6333 : 0 : case ST_EXIT:
6334 : 0 : case ST_END_FUNCTION:
6335 : 0 : case ST_CYCLE:
6336 : 0 : case ST_PAUSE:
6337 : 0 : case ST_STOP:
6338 : 0 : case ST_ERROR_STOP:
6339 : 0 : case ST_END_SUBROUTINE:
6340 : :
6341 : 0 : case ST_DO:
6342 : 0 : case ST_FORALL:
6343 : 0 : case ST_WHERE:
6344 : 0 : case ST_SELECT_CASE:
6345 : 0 : gfc_error ("%s statement at %C cannot terminate a non-block "
6346 : : "DO loop", gfc_ascii_statement (st));
6347 : 0 : break;
6348 : :
6349 : : default:
6350 : : break;
6351 : : }
6352 : :
6353 : 745672 : switch (st)
6354 : : {
6355 : 10 : case ST_NONE:
6356 : 10 : unexpected_eof ();
6357 : :
6358 : 23 : case ST_DATA:
6359 : 23 : gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the "
6360 : : "first executable statement");
6361 : : /* Fall through. */
6362 : :
6363 : 536314 : case ST_FORMAT:
6364 : 536314 : case ST_ENTRY:
6365 : 536314 : case_executable:
6366 : 536314 : accept_statement (st);
6367 : 536314 : if (close_flag == 1)
6368 : : return ST_IMPLIED_ENDDO;
6369 : : break;
6370 : :
6371 : 884 : case ST_BLOCK:
6372 : 884 : parse_block_construct ();
6373 : 884 : break;
6374 : :
6375 : 1278 : case ST_ASSOCIATE:
6376 : 1278 : parse_associate ();
6377 : 1278 : break;
6378 : :
6379 : 13985 : case ST_IF_BLOCK:
6380 : 13985 : parse_if_block ();
6381 : 13985 : break;
6382 : :
6383 : 553 : case ST_SELECT_CASE:
6384 : 553 : parse_select_block ();
6385 : 553 : break;
6386 : :
6387 : 2859 : case ST_SELECT_TYPE:
6388 : 2859 : parse_select_type_block ();
6389 : 2859 : break;
6390 : :
6391 : 1018 : case ST_SELECT_RANK:
6392 : 1018 : parse_select_rank_block ();
6393 : 1018 : break;
6394 : :
6395 : 21681 : case ST_DO:
6396 : 21681 : parse_do_block ();
6397 : 21679 : if (check_do_closure () == 1)
6398 : : return ST_IMPLIED_ENDDO;
6399 : : break;
6400 : :
6401 : 33 : case ST_CRITICAL:
6402 : 33 : parse_critical_block ();
6403 : 33 : break;
6404 : :
6405 : 279 : case ST_WHERE_BLOCK:
6406 : 279 : parse_where_block ();
6407 : 279 : break;
6408 : :
6409 : 418 : case ST_FORALL_BLOCK:
6410 : 418 : parse_forall_block ();
6411 : 418 : break;
6412 : :
6413 : 4739 : case ST_OACC_PARALLEL_LOOP:
6414 : 4739 : case ST_OACC_KERNELS_LOOP:
6415 : 4739 : case ST_OACC_SERIAL_LOOP:
6416 : 4739 : case ST_OACC_LOOP:
6417 : 4739 : st = parse_oacc_loop (st);
6418 : 4739 : if (st == ST_IMPLIED_ENDDO)
6419 : : return st;
6420 : 4739 : continue;
6421 : :
6422 : 4534 : case ST_OACC_PARALLEL:
6423 : 4534 : case ST_OACC_KERNELS:
6424 : 4534 : case ST_OACC_SERIAL:
6425 : 4534 : case ST_OACC_DATA:
6426 : 4534 : case ST_OACC_HOST_DATA:
6427 : 4534 : parse_oacc_structured_block (st);
6428 : 4534 : break;
6429 : :
6430 : 70 : case ST_OMP_ALLOCATE_EXEC:
6431 : 70 : case ST_OMP_ALLOCATORS:
6432 : 70 : st = parse_openmp_allocate_block (st);
6433 : 70 : continue;
6434 : :
6435 : 8033 : case ST_OMP_ASSUME:
6436 : 8033 : case ST_OMP_PARALLEL:
6437 : 8033 : case ST_OMP_PARALLEL_MASKED:
6438 : 8033 : case ST_OMP_PARALLEL_MASTER:
6439 : 8033 : case ST_OMP_PARALLEL_SECTIONS:
6440 : 8033 : case ST_OMP_ORDERED:
6441 : 8033 : case ST_OMP_CRITICAL:
6442 : 8033 : case ST_OMP_MASKED:
6443 : 8033 : case ST_OMP_MASTER:
6444 : 8033 : case ST_OMP_SCOPE:
6445 : 8033 : case ST_OMP_SECTIONS:
6446 : 8033 : case ST_OMP_SINGLE:
6447 : 8033 : case ST_OMP_TARGET:
6448 : 8033 : case ST_OMP_TARGET_DATA:
6449 : 8033 : case ST_OMP_TARGET_PARALLEL:
6450 : 8033 : case ST_OMP_TARGET_TEAMS:
6451 : 8033 : case ST_OMP_TEAMS:
6452 : 8033 : case ST_OMP_TASK:
6453 : 8033 : case ST_OMP_TASKGROUP:
6454 : 8033 : st = parse_omp_structured_block (st, false);
6455 : 8020 : continue;
6456 : :
6457 : 94 : case ST_OMP_WORKSHARE:
6458 : 94 : case ST_OMP_PARALLEL_WORKSHARE:
6459 : 94 : st = parse_omp_structured_block (st, true);
6460 : 93 : continue;
6461 : :
6462 : 4779 : case ST_OMP_DISTRIBUTE:
6463 : 4779 : case ST_OMP_DISTRIBUTE_PARALLEL_DO:
6464 : 4779 : case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
6465 : 4779 : case ST_OMP_DISTRIBUTE_SIMD:
6466 : 4779 : case ST_OMP_DO:
6467 : 4779 : case ST_OMP_DO_SIMD:
6468 : 4779 : case ST_OMP_LOOP:
6469 : 4779 : case ST_OMP_PARALLEL_DO:
6470 : 4779 : case ST_OMP_PARALLEL_DO_SIMD:
6471 : 4779 : case ST_OMP_PARALLEL_LOOP:
6472 : 4779 : case ST_OMP_PARALLEL_MASKED_TASKLOOP:
6473 : 4779 : case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
6474 : 4779 : case ST_OMP_PARALLEL_MASTER_TASKLOOP:
6475 : 4779 : case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
6476 : 4779 : case ST_OMP_MASKED_TASKLOOP:
6477 : 4779 : case ST_OMP_MASKED_TASKLOOP_SIMD:
6478 : 4779 : case ST_OMP_MASTER_TASKLOOP:
6479 : 4779 : case ST_OMP_MASTER_TASKLOOP_SIMD:
6480 : 4779 : case ST_OMP_SIMD:
6481 : 4779 : case ST_OMP_TARGET_PARALLEL_DO:
6482 : 4779 : case ST_OMP_TARGET_PARALLEL_DO_SIMD:
6483 : 4779 : case ST_OMP_TARGET_PARALLEL_LOOP:
6484 : 4779 : case ST_OMP_TARGET_SIMD:
6485 : 4779 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
6486 : 4779 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
6487 : 4779 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6488 : 4779 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
6489 : 4779 : case ST_OMP_TARGET_TEAMS_LOOP:
6490 : 4779 : case ST_OMP_TASKLOOP:
6491 : 4779 : case ST_OMP_TASKLOOP_SIMD:
6492 : 4779 : case ST_OMP_TEAMS_DISTRIBUTE:
6493 : 4779 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
6494 : 4779 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6495 : 4779 : case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
6496 : 4779 : case ST_OMP_TEAMS_LOOP:
6497 : 4779 : case ST_OMP_TILE:
6498 : 4779 : case ST_OMP_UNROLL:
6499 : 4779 : st = parse_omp_do (st, 0);
6500 : 4777 : if (st == ST_IMPLIED_ENDDO)
6501 : : return st;
6502 : 4775 : continue;
6503 : :
6504 : 543 : case ST_OACC_ATOMIC:
6505 : 543 : st = parse_omp_oacc_atomic (false);
6506 : 543 : continue;
6507 : :
6508 : 2157 : case ST_OMP_ATOMIC:
6509 : 2157 : st = parse_omp_oacc_atomic (true);
6510 : 2157 : continue;
6511 : :
6512 : 77 : case ST_OMP_DISPATCH:
6513 : 77 : st = parse_omp_dispatch ();
6514 : 77 : continue;
6515 : :
6516 : : default:
6517 : : return st;
6518 : : }
6519 : :
6520 : 581671 : if (directive_unroll != -1)
6521 : 1 : gfc_error ("%<GCC unroll%> directive not at the start of a loop at %C");
6522 : :
6523 : 581671 : if (directive_ivdep)
6524 : 0 : gfc_error ("%<GCC ivdep%> directive not at the start of a loop at %C");
6525 : :
6526 : 581671 : if (directive_vector)
6527 : 0 : gfc_error ("%<GCC vector%> directive not at the start of a loop at %C");
6528 : :
6529 : 581671 : if (directive_novector)
6530 : 0 : gfc_error ("%<GCC novector%> "
6531 : : "directive not at the start of a loop at %C");
6532 : :
6533 : 581671 : st = next_statement ();
6534 : : }
6535 : : }
6536 : :
6537 : :
6538 : : /* Fix the symbols for sibling functions. These are incorrectly added to
6539 : : the child namespace as the parser didn't know about this procedure. */
6540 : :
6541 : : static void
6542 : 191876 : gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
6543 : : {
6544 : 191876 : gfc_namespace *ns;
6545 : 191876 : gfc_symtree *st;
6546 : 191876 : gfc_symbol *old_sym;
6547 : :
6548 : 348904 : for (ns = siblings; ns; ns = ns->sibling)
6549 : : {
6550 : 157028 : st = gfc_find_symtree (ns->sym_root, sym->name);
6551 : :
6552 : 157028 : if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
6553 : 118987 : goto fixup_contained;
6554 : :
6555 : 38041 : if ((st->n.sym->attr.flavor == FL_DERIVED
6556 : 0 : && sym->attr.generic && sym->attr.function)
6557 : 38041 : ||(sym->attr.flavor == FL_DERIVED
6558 : 0 : && st->n.sym->attr.generic && st->n.sym->attr.function))
6559 : 0 : goto fixup_contained;
6560 : :
6561 : 38041 : old_sym = st->n.sym;
6562 : 38041 : if (old_sym->ns == ns
6563 : 3439 : && !old_sym->attr.contained
6564 : :
6565 : : /* By 14.6.1.3, host association should be excluded
6566 : : for the following. */
6567 : 3430 : && !(old_sym->attr.external
6568 : 3430 : || (old_sym->ts.type != BT_UNKNOWN
6569 : 191 : && !old_sym->attr.implicit_type)
6570 : 3240 : || old_sym->attr.flavor == FL_PARAMETER
6571 : : || old_sym->attr.use_assoc
6572 : : || old_sym->attr.in_common
6573 : : || old_sym->attr.in_equivalence
6574 : : || old_sym->attr.data
6575 : : || old_sym->attr.dummy
6576 : : || old_sym->attr.result
6577 : : || old_sym->attr.dimension
6578 : : || old_sym->attr.allocatable
6579 : : || old_sym->attr.intrinsic
6580 : 3240 : || old_sym->attr.generic
6581 : 3225 : || old_sym->attr.flavor == FL_NAMELIST
6582 : 3224 : || old_sym->attr.flavor == FL_LABEL
6583 : 3223 : || old_sym->attr.proc == PROC_ST_FUNCTION))
6584 : : {
6585 : : /* Replace it with the symbol from the parent namespace. */
6586 : 3223 : st->n.sym = sym;
6587 : 3223 : sym->refs++;
6588 : :
6589 : 3223 : gfc_release_symbol (old_sym);
6590 : : }
6591 : :
6592 : 34818 : fixup_contained:
6593 : : /* Do the same for any contained procedures. */
6594 : 157028 : gfc_fixup_sibling_symbols (sym, ns->contained);
6595 : : }
6596 : 191876 : }
6597 : :
6598 : : static void
6599 : 14128 : parse_contained (int module)
6600 : : {
6601 : 14128 : gfc_namespace *ns, *parent_ns, *tmp;
6602 : 14128 : gfc_state_data s1, s2;
6603 : 14128 : gfc_statement st;
6604 : 14128 : gfc_symbol *sym;
6605 : 14128 : gfc_entry_list *el;
6606 : 14128 : locus old_loc;
6607 : 14128 : int contains_statements = 0;
6608 : 14128 : int seen_error = 0;
6609 : :
6610 : 14128 : push_state (&s1, COMP_CONTAINS, NULL);
6611 : 14128 : parent_ns = gfc_current_ns;
6612 : :
6613 : 48721 : do
6614 : : {
6615 : 48721 : gfc_current_ns = gfc_get_namespace (parent_ns, 1);
6616 : :
6617 : 48721 : gfc_current_ns->sibling = parent_ns->contained;
6618 : 48721 : parent_ns->contained = gfc_current_ns;
6619 : :
6620 : 48744 : next:
6621 : : /* Process the next available statement. We come here if we got an error
6622 : : and rejected the last statement. */
6623 : 48744 : old_loc = gfc_current_locus;
6624 : 48744 : st = next_statement ();
6625 : :
6626 : 48743 : switch (st)
6627 : : {
6628 : 1 : case ST_NONE:
6629 : 1 : unexpected_eof ();
6630 : :
6631 : 34594 : case ST_FUNCTION:
6632 : 34594 : case ST_SUBROUTINE:
6633 : 34594 : contains_statements = 1;
6634 : 34594 : accept_statement (st);
6635 : :
6636 : 59325 : push_state (&s2,
6637 : : (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
6638 : : gfc_new_block);
6639 : :
6640 : : /* For internal procedures, create/update the symbol in the
6641 : : parent namespace. */
6642 : :
6643 : 34594 : if (!module)
6644 : : {
6645 : 18626 : if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
6646 : 0 : gfc_error ("Contained procedure %qs at %C is already "
6647 : : "ambiguous", gfc_new_block->name);
6648 : : else
6649 : : {
6650 : 18626 : if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
6651 : : sym->name,
6652 : 18626 : &gfc_new_block->declared_at))
6653 : : {
6654 : 18626 : if (st == ST_FUNCTION)
6655 : 4346 : gfc_add_function (&sym->attr, sym->name,
6656 : 4346 : &gfc_new_block->declared_at);
6657 : : else
6658 : 14280 : gfc_add_subroutine (&sym->attr, sym->name,
6659 : 14280 : &gfc_new_block->declared_at);
6660 : : }
6661 : : }
6662 : :
6663 : 18626 : gfc_commit_symbols ();
6664 : : }
6665 : : else
6666 : 15968 : sym = gfc_new_block;
6667 : :
6668 : : /* Mark this as a contained function, so it isn't replaced
6669 : : by other module functions. */
6670 : 34594 : sym->attr.contained = 1;
6671 : :
6672 : : /* Set implicit_pure so that it can be reset if any of the
6673 : : tests for purity fail. This is used for some optimisation
6674 : : during translation. */
6675 : 34594 : if (!sym->attr.pure)
6676 : 32565 : sym->attr.implicit_pure = 1;
6677 : :
6678 : 34594 : parse_progunit (ST_NONE);
6679 : :
6680 : : /* Fix up any sibling functions that refer to this one. */
6681 : 34593 : gfc_fixup_sibling_symbols (sym, gfc_current_ns);
6682 : : /* Or refer to any of its alternate entry points. */
6683 : 34848 : for (el = gfc_current_ns->entries; el; el = el->next)
6684 : 255 : gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
6685 : :
6686 : 34593 : gfc_current_ns->code = s2.head;
6687 : 34593 : gfc_current_ns = parent_ns;
6688 : :
6689 : 34593 : pop_state ();
6690 : 34593 : break;
6691 : :
6692 : : /* These statements are associated with the end of the host unit. */
6693 : 14125 : case ST_END_FUNCTION:
6694 : 14125 : case ST_END_MODULE:
6695 : 14125 : case ST_END_SUBMODULE:
6696 : 14125 : case ST_END_PROGRAM:
6697 : 14125 : case ST_END_SUBROUTINE:
6698 : 14125 : accept_statement (st);
6699 : 14125 : gfc_current_ns->code = s1.head;
6700 : 14125 : break;
6701 : :
6702 : 23 : default:
6703 : 23 : gfc_error ("Unexpected %s statement in CONTAINS section at %C",
6704 : : gfc_ascii_statement (st));
6705 : 23 : reject_statement ();
6706 : 23 : seen_error = 1;
6707 : 23 : goto next;
6708 : 48718 : break;
6709 : : }
6710 : : }
6711 : 48718 : while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
6712 : 47934 : && st != ST_END_MODULE && st != ST_END_SUBMODULE
6713 : 89748 : && st != ST_END_PROGRAM);
6714 : :
6715 : : /* The first namespace in the list is guaranteed to not have
6716 : : anything (worthwhile) in it. */
6717 : 14125 : tmp = gfc_current_ns;
6718 : 14125 : gfc_current_ns = parent_ns;
6719 : 14125 : if (seen_error && tmp->refs > 1)
6720 : 0 : gfc_free_namespace (tmp);
6721 : :
6722 : 14125 : ns = gfc_current_ns->contained;
6723 : 14125 : gfc_current_ns->contained = ns->sibling;
6724 : 14125 : gfc_free_namespace (ns);
6725 : :
6726 : 14125 : pop_state ();
6727 : 14125 : if (!contains_statements)
6728 : 64 : gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without "
6729 : : "FUNCTION or SUBROUTINE statement at %L", &old_loc);
6730 : 14125 : }
6731 : :
6732 : :
6733 : : /* The result variable in a MODULE PROCEDURE needs to be created and
6734 : : its characteristics copied from the interface since it is neither
6735 : : declared in the procedure declaration nor in the specification
6736 : : part. */
6737 : :
6738 : : static void
6739 : 52 : get_modproc_result (void)
6740 : : {
6741 : 52 : gfc_symbol *proc;
6742 : 52 : if (gfc_state_stack->previous
6743 : 52 : && gfc_state_stack->previous->state == COMP_CONTAINS
6744 : 52 : && gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
6745 : : {
6746 : 39 : proc = gfc_current_ns->proc_name ? gfc_current_ns->proc_name : NULL;
6747 : 39 : if (proc != NULL
6748 : 39 : && proc->attr.function
6749 : 39 : && proc->tlink
6750 : 39 : && proc->tlink->result
6751 : 39 : && proc->tlink->result != proc->tlink)
6752 : : {
6753 : 15 : gfc_copy_dummy_sym (&proc->result, proc->tlink->result, 1);
6754 : 15 : gfc_set_sym_referenced (proc->result);
6755 : 15 : proc->result->attr.if_source = IFSRC_DECL;
6756 : 15 : gfc_commit_symbol (proc->result);
6757 : : }
6758 : : }
6759 : 52 : }
6760 : :
6761 : :
6762 : : /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
6763 : :
6764 : : static void
6765 : 73451 : parse_progunit (gfc_statement st)
6766 : : {
6767 : 73451 : gfc_state_data *p;
6768 : 73451 : int n;
6769 : :
6770 : 73451 : gfc_adjust_builtins ();
6771 : :
6772 : 73451 : if (gfc_new_block
6773 : 65154 : && gfc_new_block->abr_modproc_decl
6774 : 178 : && gfc_new_block->attr.function)
6775 : 52 : get_modproc_result ();
6776 : :
6777 : 73451 : st = parse_spec (st);
6778 : 73434 : switch (st)
6779 : : {
6780 : 0 : case ST_NONE:
6781 : 0 : unexpected_eof ();
6782 : :
6783 : 178 : case ST_CONTAINS:
6784 : : /* This is not allowed within BLOCK! */
6785 : 178 : if (gfc_current_state () != COMP_BLOCK)
6786 : 177 : goto contains;
6787 : : break;
6788 : :
6789 : 4248 : case_end:
6790 : 4248 : accept_statement (st);
6791 : 4248 : goto done;
6792 : :
6793 : : default:
6794 : : break;
6795 : : }
6796 : :
6797 : 69009 : if (gfc_current_state () == COMP_FUNCTION)
6798 : 12118 : gfc_check_function_type (gfc_current_ns);
6799 : :
6800 : 56891 : loop:
6801 : 69423 : for (;;)
6802 : : {
6803 : 69216 : st = parse_executable (st);
6804 : :
6805 : 69193 : switch (st)
6806 : : {
6807 : 0 : case ST_NONE:
6808 : 0 : unexpected_eof ();
6809 : :
6810 : 7048 : case ST_CONTAINS:
6811 : : /* This is not allowed within BLOCK! */
6812 : 7048 : if (gfc_current_state () != COMP_BLOCK)
6813 : 7046 : goto contains;
6814 : : break;
6815 : :
6816 : 61940 : case_end:
6817 : 61940 : accept_statement (st);
6818 : 61940 : goto done;
6819 : :
6820 : : default:
6821 : : break;
6822 : : }
6823 : :
6824 : 207 : unexpected_statement (st);
6825 : 207 : reject_statement ();
6826 : 207 : st = next_statement ();
6827 : : }
6828 : :
6829 : 7223 : contains:
6830 : 7223 : n = 0;
6831 : :
6832 : 22249 : for (p = gfc_state_stack; p; p = p->previous)
6833 : 15026 : if (p->state == COMP_CONTAINS)
6834 : 290 : n++;
6835 : :
6836 : 7223 : if (gfc_find_state (COMP_MODULE) == true
6837 : 7223 : || gfc_find_state (COMP_SUBMODULE) == true)
6838 : 290 : n--;
6839 : :
6840 : 7223 : if (n > 0)
6841 : : {
6842 : 0 : gfc_error ("CONTAINS statement at %C is already in a contained "
6843 : : "program unit");
6844 : 0 : reject_statement ();
6845 : 0 : st = next_statement ();
6846 : 0 : goto loop;
6847 : : }
6848 : :
6849 : 7223 : parse_contained (0);
6850 : :
6851 : 73409 : done:
6852 : 73409 : gfc_current_ns->code = gfc_state_stack->head;
6853 : 73409 : }
6854 : :
6855 : :
6856 : : /* Come here to complain about a global symbol already in use as
6857 : : something else. */
6858 : :
6859 : : void
6860 : 19 : gfc_global_used (gfc_gsymbol *sym, locus *where)
6861 : : {
6862 : 19 : const char *name;
6863 : :
6864 : 19 : if (where == NULL)
6865 : 0 : where = &gfc_current_locus;
6866 : :
6867 : 19 : switch(sym->type)
6868 : : {
6869 : : case GSYM_PROGRAM:
6870 : : name = "PROGRAM";
6871 : : break;
6872 : 3 : case GSYM_FUNCTION:
6873 : 3 : name = "FUNCTION";
6874 : 3 : break;
6875 : 9 : case GSYM_SUBROUTINE:
6876 : 9 : name = "SUBROUTINE";
6877 : 9 : break;
6878 : 3 : case GSYM_COMMON:
6879 : 3 : name = "COMMON";
6880 : 3 : break;
6881 : 0 : case GSYM_BLOCK_DATA:
6882 : 0 : name = "BLOCK DATA";
6883 : 0 : break;
6884 : 2 : case GSYM_MODULE:
6885 : 2 : name = "MODULE";
6886 : 2 : break;
6887 : 1 : default:
6888 : 1 : name = NULL;
6889 : : }
6890 : :
6891 : 17 : if (name)
6892 : : {
6893 : 18 : if (sym->binding_label)
6894 : 3 : gfc_error ("Global binding name %qs at %L is already being used "
6895 : : "as a %s at %L", sym->binding_label, where, name,
6896 : : &sym->where);
6897 : : else
6898 : 15 : gfc_error ("Global name %qs at %L is already being used as "
6899 : : "a %s at %L", sym->name, where, name, &sym->where);
6900 : : }
6901 : : else
6902 : : {
6903 : 1 : if (sym->binding_label)
6904 : 1 : gfc_error ("Global binding name %qs at %L is already being used "
6905 : : "at %L", sym->binding_label, where, &sym->where);
6906 : : else
6907 : 0 : gfc_error ("Global name %qs at %L is already being used at %L",
6908 : : sym->name, where, &sym->where);
6909 : : }
6910 : 19 : }
6911 : :
6912 : :
6913 : : /* Parse a block data program unit. */
6914 : :
6915 : : static void
6916 : 83 : parse_block_data (void)
6917 : : {
6918 : 83 : gfc_statement st;
6919 : 83 : static locus blank_locus;
6920 : 83 : static int blank_block=0;
6921 : 83 : gfc_gsymbol *s;
6922 : :
6923 : 83 : gfc_current_ns->proc_name = gfc_new_block;
6924 : 83 : gfc_current_ns->is_block_data = 1;
6925 : :
6926 : 83 : if (gfc_new_block == NULL)
6927 : : {
6928 : 48 : if (blank_block)
6929 : 0 : gfc_error ("Blank BLOCK DATA at %C conflicts with "
6930 : : "prior BLOCK DATA at %L", &blank_locus);
6931 : : else
6932 : : {
6933 : 48 : blank_block = 1;
6934 : 48 : blank_locus = gfc_current_locus;
6935 : : }
6936 : : }
6937 : : else
6938 : : {
6939 : 35 : s = gfc_get_gsymbol (gfc_new_block->name, false);
6940 : 35 : if (s->defined
6941 : 35 : || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
6942 : 0 : gfc_global_used (s, &gfc_new_block->declared_at);
6943 : : else
6944 : : {
6945 : 35 : s->type = GSYM_BLOCK_DATA;
6946 : 35 : s->where = gfc_new_block->declared_at;
6947 : 35 : s->defined = 1;
6948 : : }
6949 : : }
6950 : :
6951 : 83 : st = parse_spec (ST_NONE);
6952 : :
6953 : 166 : while (st != ST_END_BLOCK_DATA)
6954 : : {
6955 : 1 : gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
6956 : : gfc_ascii_statement (st));
6957 : 1 : reject_statement ();
6958 : 1 : st = next_statement ();
6959 : : }
6960 : 82 : }
6961 : :
6962 : :
6963 : : /* Following the association of the ancestor (sub)module symbols, they
6964 : : must be set host rather than use associated and all must be public.
6965 : : They are flagged up by 'used_in_submodule' so that they can be set
6966 : : DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
6967 : : linker chokes on multiple symbol definitions. */
6968 : :
6969 : : static void
6970 : 1867 : set_syms_host_assoc (gfc_symbol *sym)
6971 : : {
6972 : 1867 : gfc_component *c;
6973 : 1867 : const char dot[2] = ".";
6974 : : /* Symbols take the form module.submodule_ or module.name_. */
6975 : 1867 : char parent1[2 * GFC_MAX_SYMBOL_LEN + 2];
6976 : 1867 : char parent2[2 * GFC_MAX_SYMBOL_LEN + 2];
6977 : :
6978 : 1867 : if (sym == NULL)
6979 : 0 : return;
6980 : :
6981 : 1867 : if (sym->attr.module_procedure)
6982 : 505 : sym->attr.external = 0;
6983 : :
6984 : 1867 : sym->attr.use_assoc = 0;
6985 : 1867 : sym->attr.host_assoc = 1;
6986 : 1867 : sym->attr.used_in_submodule =1;
6987 : :
6988 : 1867 : if (sym->attr.flavor == FL_DERIVED)
6989 : : {
6990 : : /* Derived types with PRIVATE components that are declared in
6991 : : modules other than the parent module must not be changed to be
6992 : : PUBLIC. The 'use-assoc' attribute must be reset so that the
6993 : : test in symbol.cc(gfc_find_component) works correctly. This is
6994 : : not necessary for PRIVATE symbols since they are not read from
6995 : : the module. */
6996 : 299 : memset(parent1, '\0', sizeof(parent1));
6997 : 299 : memset(parent2, '\0', sizeof(parent2));
6998 : 299 : strcpy (parent1, gfc_new_block->name);
6999 : 299 : strcpy (parent2, sym->module);
7000 : 299 : if (strcmp (strtok (parent1, dot), strtok (parent2, dot)) == 0)
7001 : : {
7002 : 1343 : for (c = sym->components; c; c = c->next)
7003 : 1078 : c->attr.access = ACCESS_PUBLIC;
7004 : : }
7005 : : else
7006 : : {
7007 : 34 : sym->attr.use_assoc = 1;
7008 : 34 : sym->attr.host_assoc = 0;
7009 : : }
7010 : : }
7011 : : }
7012 : :
7013 : : /* Parse a module subprogram. */
7014 : :
7015 : : static void
7016 : 9363 : parse_module (void)
7017 : : {
7018 : 9363 : gfc_statement st;
7019 : 9363 : gfc_gsymbol *s;
7020 : :
7021 : 9363 : s = gfc_get_gsymbol (gfc_new_block->name, false);
7022 : 9363 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
7023 : 1 : gfc_global_used (s, &gfc_new_block->declared_at);
7024 : : else
7025 : : {
7026 : 9362 : s->type = GSYM_MODULE;
7027 : 9362 : s->where = gfc_new_block->declared_at;
7028 : 9362 : s->defined = 1;
7029 : : }
7030 : :
7031 : : /* Something is nulling the module_list after this point. This is good
7032 : : since it allows us to 'USE' the parent modules that the submodule
7033 : : inherits and to set (most) of the symbols as host associated. */
7034 : 9363 : if (gfc_current_state () == COMP_SUBMODULE)
7035 : : {
7036 : 201 : use_modules ();
7037 : 200 : gfc_traverse_ns (gfc_current_ns, set_syms_host_assoc);
7038 : : }
7039 : :
7040 : 9362 : st = parse_spec (ST_NONE);
7041 : :
7042 : 9364 : loop:
7043 : 9364 : switch (st)
7044 : : {
7045 : 0 : case ST_NONE:
7046 : 0 : unexpected_eof ();
7047 : :
7048 : 6905 : case ST_CONTAINS:
7049 : 6905 : parse_contained (1);
7050 : 6905 : break;
7051 : :
7052 : 2456 : case ST_END_MODULE:
7053 : 2456 : case ST_END_SUBMODULE:
7054 : 2456 : accept_statement (st);
7055 : 2456 : break;
7056 : :
7057 : 3 : default:
7058 : 3 : gfc_error ("Unexpected %s statement in MODULE at %C",
7059 : : gfc_ascii_statement (st));
7060 : 3 : reject_statement ();
7061 : 3 : st = next_statement ();
7062 : 3 : goto loop;
7063 : : }
7064 : 9360 : s->ns = gfc_current_ns;
7065 : 9360 : }
7066 : :
7067 : :
7068 : : /* Add a procedure name to the global symbol table. */
7069 : :
7070 : : static void
7071 : 11180 : add_global_procedure (bool sub)
7072 : : {
7073 : 11180 : gfc_gsymbol *s;
7074 : :
7075 : : /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7076 : : name is a global identifier. */
7077 : 11180 : if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008))
7078 : : {
7079 : 10801 : s = gfc_get_gsymbol (gfc_new_block->name, false);
7080 : :
7081 : 10801 : if (s->defined
7082 : 10799 : || (s->type != GSYM_UNKNOWN
7083 : 100 : && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
7084 : : {
7085 : 2 : gfc_global_used (s, &gfc_new_block->declared_at);
7086 : : /* Silence follow-up errors. */
7087 : 2 : gfc_new_block->binding_label = NULL;
7088 : : }
7089 : : else
7090 : : {
7091 : 10799 : s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
7092 : 10799 : s->sym_name = gfc_new_block->name;
7093 : 10799 : s->where = gfc_new_block->declared_at;
7094 : 10799 : s->defined = 1;
7095 : 10799 : s->ns = gfc_current_ns;
7096 : : }
7097 : : }
7098 : :
7099 : : /* Don't add the symbol multiple times. */
7100 : 11180 : if (gfc_new_block->binding_label
7101 : 11180 : && (!gfc_notification_std (GFC_STD_F2008)
7102 : 59 : || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0))
7103 : : {
7104 : 380 : s = gfc_get_gsymbol (gfc_new_block->binding_label, true);
7105 : :
7106 : 380 : if (s->defined
7107 : 377 : || (s->type != GSYM_UNKNOWN
7108 : 4 : && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
7109 : : {
7110 : 3 : gfc_global_used (s, &gfc_new_block->declared_at);
7111 : : /* Silence follow-up errors. */
7112 : 3 : gfc_new_block->binding_label = NULL;
7113 : : }
7114 : : else
7115 : : {
7116 : 377 : s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
7117 : 377 : s->sym_name = gfc_new_block->name;
7118 : 377 : s->binding_label = gfc_new_block->binding_label;
7119 : 377 : s->where = gfc_new_block->declared_at;
7120 : 377 : s->defined = 1;
7121 : 377 : s->ns = gfc_current_ns;
7122 : : }
7123 : : }
7124 : 11180 : }
7125 : :
7126 : :
7127 : : /* Add a program to the global symbol table. */
7128 : :
7129 : : static void
7130 : 18451 : add_global_program (void)
7131 : : {
7132 : 18451 : gfc_gsymbol *s;
7133 : :
7134 : 18451 : if (gfc_new_block == NULL)
7135 : : return;
7136 : 18451 : s = gfc_get_gsymbol (gfc_new_block->name, false);
7137 : :
7138 : 18451 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
7139 : 0 : gfc_global_used (s, &gfc_new_block->declared_at);
7140 : : else
7141 : : {
7142 : 18451 : s->type = GSYM_PROGRAM;
7143 : 18451 : s->where = gfc_new_block->declared_at;
7144 : 18451 : s->defined = 1;
7145 : 18451 : s->ns = gfc_current_ns;
7146 : : }
7147 : : }
7148 : :
7149 : :
7150 : : /* Resolve all the program units. */
7151 : : static void
7152 : 30454 : resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
7153 : : {
7154 : 30454 : gfc_derived_types = NULL;
7155 : 30454 : gfc_current_ns = gfc_global_ns_list;
7156 : 75071 : for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
7157 : : {
7158 : 44618 : if (gfc_current_ns->proc_name
7159 : 44618 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
7160 : 9350 : continue; /* Already resolved. */
7161 : :
7162 : 35268 : if (gfc_current_ns->proc_name)
7163 : 35268 : gfc_current_locus = gfc_current_ns->proc_name->declared_at;
7164 : 35268 : gfc_resolve (gfc_current_ns);
7165 : 35267 : gfc_current_ns->derived_types = gfc_derived_types;
7166 : 35267 : gfc_derived_types = NULL;
7167 : : }
7168 : 30453 : }
7169 : :
7170 : :
7171 : : static void
7172 : 190945 : clean_up_modules (gfc_gsymbol *&gsym)
7173 : : {
7174 : 190945 : if (gsym == NULL)
7175 : : return;
7176 : :
7177 : 80246 : clean_up_modules (gsym->left);
7178 : 80246 : clean_up_modules (gsym->right);
7179 : :
7180 : 80246 : if (gsym->type != GSYM_MODULE)
7181 : : return;
7182 : :
7183 : 9707 : if (gsym->ns)
7184 : : {
7185 : 9707 : gfc_current_ns = gsym->ns;
7186 : 9707 : gfc_derived_types = gfc_current_ns->derived_types;
7187 : 9707 : gfc_done_2 ();
7188 : 9707 : gsym->ns = NULL;
7189 : : }
7190 : 9707 : free (gsym);
7191 : 9707 : gsym = NULL;
7192 : : }
7193 : :
7194 : :
7195 : : /* Translate all the program units. This could be in a different order
7196 : : to resolution if there are forward references in the file. */
7197 : : static void
7198 : 30453 : translate_all_program_units (gfc_namespace *gfc_global_ns_list)
7199 : : {
7200 : 30453 : int errors;
7201 : :
7202 : 30453 : gfc_current_ns = gfc_global_ns_list;
7203 : 30453 : gfc_get_errors (NULL, &errors);
7204 : :
7205 : : /* We first translate all modules to make sure that later parts
7206 : : of the program can use the decl. Then we translate the nonmodules. */
7207 : :
7208 : 104557 : for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
7209 : : {
7210 : 43651 : if (!gfc_current_ns->proc_name
7211 : 43651 : || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
7212 : 35075 : continue;
7213 : :
7214 : 8576 : gfc_current_locus = gfc_current_ns->proc_name->declared_at;
7215 : 8576 : gfc_derived_types = gfc_current_ns->derived_types;
7216 : 8576 : gfc_generate_module_code (gfc_current_ns);
7217 : 8576 : gfc_current_ns->translated = 1;
7218 : : }
7219 : :
7220 : 30453 : gfc_current_ns = gfc_global_ns_list;
7221 : 74104 : for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
7222 : : {
7223 : 43651 : if (gfc_current_ns->proc_name
7224 : 43651 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
7225 : 8576 : continue;
7226 : :
7227 : 35075 : gfc_current_locus = gfc_current_ns->proc_name->declared_at;
7228 : 35075 : gfc_derived_types = gfc_current_ns->derived_types;
7229 : 35075 : gfc_generate_code (gfc_current_ns);
7230 : 35075 : gfc_current_ns->translated = 1;
7231 : : }
7232 : :
7233 : : /* Clean up all the namespaces after translation. */
7234 : 30453 : gfc_current_ns = gfc_global_ns_list;
7235 : 77737 : for (;gfc_current_ns;)
7236 : : {
7237 : 47284 : gfc_namespace *ns;
7238 : :
7239 : 47284 : if (gfc_current_ns->proc_name
7240 : 47284 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
7241 : : {
7242 : 9350 : gfc_current_ns = gfc_current_ns->sibling;
7243 : 9350 : continue;
7244 : : }
7245 : :
7246 : 37934 : ns = gfc_current_ns->sibling;
7247 : 37934 : gfc_derived_types = gfc_current_ns->derived_types;
7248 : 37934 : gfc_done_2 ();
7249 : 37934 : gfc_current_ns = ns;
7250 : : }
7251 : :
7252 : 30453 : clean_up_modules (gfc_gsym_root);
7253 : 30453 : }
7254 : :
7255 : :
7256 : : /* Top level parser. */
7257 : :
7258 : : bool
7259 : 30496 : gfc_parse_file (void)
7260 : : {
7261 : 30496 : int seen_program, errors_before, errors;
7262 : 30496 : gfc_state_data top, s;
7263 : 30496 : gfc_statement st;
7264 : 30496 : locus prog_locus;
7265 : 30496 : gfc_namespace *next;
7266 : :
7267 : 30496 : gfc_start_source_files ();
7268 : :
7269 : 30496 : top.state = COMP_NONE;
7270 : 30496 : top.sym = NULL;
7271 : 30496 : top.previous = NULL;
7272 : 30496 : top.head = top.tail = NULL;
7273 : 30496 : top.do_variable = NULL;
7274 : :
7275 : 30496 : gfc_state_stack = ⊤
7276 : :
7277 : 30496 : gfc_clear_new_st ();
7278 : :
7279 : 30496 : gfc_statement_label = NULL;
7280 : :
7281 : 30527 : if (setjmp (eof_buf))
7282 : : return false; /* Come here on unexpected EOF */
7283 : :
7284 : : /* Prepare the global namespace that will contain the
7285 : : program units. */
7286 : 30496 : gfc_global_ns_list = next = NULL;
7287 : :
7288 : 30496 : seen_program = 0;
7289 : 30496 : errors_before = 0;
7290 : :
7291 : : /* Exit early for empty files. */
7292 : 30496 : if (gfc_at_eof ())
7293 : 0 : goto done;
7294 : :
7295 : 30496 : in_specification_block = true;
7296 : 77878 : loop:
7297 : 77878 : gfc_init_2 ();
7298 : 77878 : st = next_statement ();
7299 : 77875 : switch (st)
7300 : : {
7301 : 30454 : case ST_NONE:
7302 : 30454 : gfc_done_2 ();
7303 : 30454 : goto done;
7304 : :
7305 : 18452 : case ST_PROGRAM:
7306 : 18452 : if (seen_program)
7307 : 1 : goto duplicate_main;
7308 : 18451 : seen_program = 1;
7309 : 18451 : prog_locus = gfc_current_locus;
7310 : :
7311 : 18451 : push_state (&s, COMP_PROGRAM, gfc_new_block);
7312 : 18451 : main_program_symbol (gfc_current_ns, gfc_new_block->name);
7313 : 18451 : accept_statement (st);
7314 : 18451 : add_global_program ();
7315 : 18451 : parse_progunit (ST_NONE);
7316 : 18434 : goto prog_units;
7317 : :
7318 : 8344 : case ST_SUBROUTINE:
7319 : 8344 : add_global_procedure (true);
7320 : 8344 : push_state (&s, COMP_SUBROUTINE, gfc_new_block);
7321 : 8344 : accept_statement (st);
7322 : 8344 : parse_progunit (ST_NONE);
7323 : 8339 : goto prog_units;
7324 : :
7325 : 2836 : case ST_FUNCTION:
7326 : 2836 : add_global_procedure (false);
7327 : 2836 : push_state (&s, COMP_FUNCTION, gfc_new_block);
7328 : 2836 : accept_statement (st);
7329 : 2836 : parse_progunit (ST_NONE);
7330 : 2836 : goto prog_units;
7331 : :
7332 : 83 : case ST_BLOCK_DATA:
7333 : 83 : push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
7334 : 83 : accept_statement (st);
7335 : 83 : parse_block_data ();
7336 : : break;
7337 : :
7338 : 9162 : case ST_MODULE:
7339 : 9162 : push_state (&s, COMP_MODULE, gfc_new_block);
7340 : 9162 : accept_statement (st);
7341 : :
7342 : 9162 : gfc_get_errors (NULL, &errors_before);
7343 : 9162 : parse_module ();
7344 : : break;
7345 : :
7346 : 201 : case ST_SUBMODULE:
7347 : 201 : push_state (&s, COMP_SUBMODULE, gfc_new_block);
7348 : 201 : accept_statement (st);
7349 : :
7350 : 201 : gfc_get_errors (NULL, &errors_before);
7351 : 201 : parse_module ();
7352 : : break;
7353 : :
7354 : : /* Anything else starts a nameless main program block. */
7355 : 8343 : default:
7356 : 8343 : if (seen_program)
7357 : 1 : goto duplicate_main;
7358 : 8342 : seen_program = 1;
7359 : 8342 : prog_locus = gfc_current_locus;
7360 : :
7361 : 8342 : push_state (&s, COMP_PROGRAM, gfc_new_block);
7362 : 8342 : main_program_symbol (gfc_current_ns, "MAIN__");
7363 : 8342 : parse_progunit (st);
7364 : 8331 : goto prog_units;
7365 : : }
7366 : :
7367 : : /* Handle the non-program units. */
7368 : 9442 : gfc_current_ns->code = s.head;
7369 : :
7370 : 9442 : gfc_resolve (gfc_current_ns);
7371 : :
7372 : : /* Fix the implicit_pure attribute for those procedures who should
7373 : : not have it. */
7374 : 9530 : while (gfc_fix_implicit_pure (gfc_current_ns))
7375 : : ;
7376 : :
7377 : : /* Dump the parse tree if requested. */
7378 : 9442 : if (flag_dump_fortran_original)
7379 : 0 : gfc_dump_parse_tree (gfc_current_ns, stdout);
7380 : :
7381 : 9442 : gfc_get_errors (NULL, &errors);
7382 : 9442 : if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE)
7383 : : {
7384 : 9360 : gfc_dump_module (s.sym->name, errors_before == errors);
7385 : 9360 : gfc_current_ns->derived_types = gfc_derived_types;
7386 : 9360 : gfc_derived_types = NULL;
7387 : 9360 : goto prog_units;
7388 : : }
7389 : : else
7390 : : {
7391 : 82 : if (errors == 0)
7392 : 71 : gfc_generate_code (gfc_current_ns);
7393 : 82 : pop_state ();
7394 : 82 : gfc_done_2 ();
7395 : : }
7396 : :
7397 : 82 : goto loop;
7398 : :
7399 : 47300 : prog_units:
7400 : : /* The main program and non-contained procedures are put
7401 : : in the global namespace list, so that they can be processed
7402 : : later and all their interfaces resolved. */
7403 : 47300 : gfc_current_ns->code = s.head;
7404 : 47300 : if (next)
7405 : : {
7406 : 17007 : for (; next->sibling; next = next->sibling)
7407 : : ;
7408 : 16996 : next->sibling = gfc_current_ns;
7409 : : }
7410 : : else
7411 : 30304 : gfc_global_ns_list = gfc_current_ns;
7412 : :
7413 : 47300 : next = gfc_current_ns;
7414 : :
7415 : 47300 : pop_state ();
7416 : 47300 : goto loop;
7417 : :
7418 : 30454 : done:
7419 : : /* Do the resolution. */
7420 : 30454 : resolve_all_program_units (gfc_global_ns_list);
7421 : :
7422 : : /* Go through all top-level namespaces and unset the implicit_pure
7423 : : attribute for any procedures that call something not pure or
7424 : : implicit_pure. Because the a procedure marked as not implicit_pure
7425 : : in one sweep may be called by another routine, we repeat this
7426 : : process until there are no more changes. */
7427 : 30472 : bool changed;
7428 : 30472 : do
7429 : : {
7430 : 30472 : changed = false;
7431 : 77781 : for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
7432 : 47309 : gfc_current_ns = gfc_current_ns->sibling)
7433 : : {
7434 : 47309 : if (gfc_fix_implicit_pure (gfc_current_ns))
7435 : 19 : changed = true;
7436 : : }
7437 : : }
7438 : : while (changed);
7439 : :
7440 : : /* Fixup for external procedures and resolve 'omp requires'. */
7441 : 30453 : int omp_requires;
7442 : 30453 : bool omp_target_seen;
7443 : 30453 : omp_requires = 0;
7444 : 30453 : omp_target_seen = false;
7445 : 77737 : for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
7446 : 47284 : gfc_current_ns = gfc_current_ns->sibling)
7447 : : {
7448 : 47284 : omp_requires |= gfc_current_ns->omp_requires;
7449 : 47284 : omp_target_seen |= gfc_current_ns->omp_target_seen;
7450 : 47284 : gfc_check_externals (gfc_current_ns);
7451 : : }
7452 : 77737 : for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
7453 : 47284 : gfc_current_ns = gfc_current_ns->sibling)
7454 : 47284 : gfc_check_omp_requires (gfc_current_ns, omp_requires);
7455 : :
7456 : : /* Populate omp_requires_mask (needed for resolving OpenMP
7457 : : metadirectives and declare variant). */
7458 : 30453 : switch (omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7459 : : {
7460 : 6 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
7461 : 6 : omp_requires_mask
7462 : 6 : = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_SEQ_CST);
7463 : 6 : break;
7464 : 3 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
7465 : 3 : omp_requires_mask
7466 : 3 : = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_ACQ_REL);
7467 : 3 : break;
7468 : 1 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE:
7469 : 1 : omp_requires_mask
7470 : 1 : = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_ACQUIRE);
7471 : 1 : break;
7472 : 4 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
7473 : 4 : omp_requires_mask
7474 : 4 : = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_RELAXED);
7475 : 4 : break;
7476 : 2 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE:
7477 : 2 : omp_requires_mask
7478 : 2 : = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_RELEASE);
7479 : 2 : break;
7480 : : }
7481 : :
7482 : 30453 : if (omp_target_seen)
7483 : 787 : omp_requires_mask = (enum omp_requires) (omp_requires_mask
7484 : : | OMP_REQUIRES_TARGET_USED);
7485 : 30453 : if (omp_requires & OMP_REQ_REVERSE_OFFLOAD)
7486 : 23 : omp_requires_mask = (enum omp_requires) (omp_requires_mask
7487 : : | OMP_REQUIRES_REVERSE_OFFLOAD);
7488 : 30453 : if (omp_requires & OMP_REQ_UNIFIED_ADDRESS)
7489 : 4 : omp_requires_mask = (enum omp_requires) (omp_requires_mask
7490 : : | OMP_REQUIRES_UNIFIED_ADDRESS);
7491 : 30453 : if (omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
7492 : 6 : omp_requires_mask
7493 : 6 : = (enum omp_requires) (omp_requires_mask
7494 : : | OMP_REQUIRES_UNIFIED_SHARED_MEMORY);
7495 : 30453 : if (omp_requires & OMP_REQ_SELF_MAPS)
7496 : 3 : omp_requires_mask
7497 : 3 : = (enum omp_requires) (omp_requires_mask | OMP_REQUIRES_SELF_MAPS);
7498 : 30453 : if (omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
7499 : 5 : omp_requires_mask = (enum omp_requires) (omp_requires_mask
7500 : : | OMP_REQUIRES_DYNAMIC_ALLOCATORS);
7501 : : /* Do the parse tree dump. */
7502 : 30453 : gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL;
7503 : :
7504 : 30493 : for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
7505 : 40 : if (!gfc_current_ns->proc_name
7506 : 40 : || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
7507 : : {
7508 : 40 : gfc_dump_parse_tree (gfc_current_ns, stdout);
7509 : 40 : fputs ("------------------------------------------\n\n", stdout);
7510 : : }
7511 : :
7512 : : /* Dump C prototypes. */
7513 : 30453 : if (flag_c_prototypes || flag_c_prototypes_external)
7514 : : {
7515 : 0 : fprintf (stdout,
7516 : : "#include <stddef.h>\n"
7517 : : "#ifdef __cplusplus\n"
7518 : : "#include <complex>\n"
7519 : : "#define __GFORTRAN_FLOAT_COMPLEX std::complex<float>\n"
7520 : : "#define __GFORTRAN_DOUBLE_COMPLEX std::complex<double>\n"
7521 : : "#define __GFORTRAN_LONG_DOUBLE_COMPLEX std::complex<long double>\n"
7522 : : "extern \"C\" {\n"
7523 : : "#else\n"
7524 : : "#define __GFORTRAN_FLOAT_COMPLEX float _Complex\n"
7525 : : "#define __GFORTRAN_DOUBLE_COMPLEX double _Complex\n"
7526 : : "#define __GFORTRAN_LONG_DOUBLE_COMPLEX long double _Complex\n"
7527 : : "#endif\n\n");
7528 : : }
7529 : :
7530 : : /* First dump BIND(C) prototypes. */
7531 : 30453 : if (flag_c_prototypes)
7532 : : {
7533 : 0 : for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
7534 : 0 : gfc_current_ns = gfc_current_ns->sibling)
7535 : 0 : gfc_dump_c_prototypes (gfc_current_ns, stdout);
7536 : : }
7537 : :
7538 : : /* Dump external prototypes. */
7539 : 30453 : if (flag_c_prototypes_external)
7540 : 0 : gfc_dump_external_c_prototypes (stdout);
7541 : :
7542 : 30453 : if (flag_c_prototypes || flag_c_prototypes_external)
7543 : 0 : fprintf (stdout, "\n#ifdef __cplusplus\n}\n#endif\n");
7544 : :
7545 : : /* Do the translation. */
7546 : 30453 : translate_all_program_units (gfc_global_ns_list);
7547 : :
7548 : : /* Dump the global symbol ist. We only do this here because part
7549 : : of it is generated after mangling the identifiers in
7550 : : trans-decl.cc. */
7551 : :
7552 : 30453 : if (flag_dump_fortran_global)
7553 : 0 : gfc_dump_global_symbols (stdout);
7554 : :
7555 : 30453 : gfc_end_source_files ();
7556 : : return true;
7557 : :
7558 : 2 : duplicate_main:
7559 : : /* If we see a duplicate main program, shut down. If the second
7560 : : instance is an implied main program, i.e. data decls or executable
7561 : : statements, we're in for lots of errors. */
7562 : 2 : gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
7563 : 2 : reject_statement ();
7564 : 2 : gfc_done_2 ();
7565 : : return true;
7566 : : }
7567 : :
7568 : : /* Return true if this state data represents an OpenACC region. */
7569 : : bool
7570 : 5 : is_oacc (gfc_state_data *sd)
7571 : : {
7572 : 5 : switch (sd->construct->op)
7573 : : {
7574 : : case EXEC_OACC_PARALLEL_LOOP:
7575 : : case EXEC_OACC_PARALLEL:
7576 : : case EXEC_OACC_KERNELS_LOOP:
7577 : : case EXEC_OACC_KERNELS:
7578 : : case EXEC_OACC_SERIAL_LOOP:
7579 : : case EXEC_OACC_SERIAL:
7580 : : case EXEC_OACC_DATA:
7581 : : case EXEC_OACC_HOST_DATA:
7582 : : case EXEC_OACC_LOOP:
7583 : : case EXEC_OACC_UPDATE:
7584 : : case EXEC_OACC_WAIT:
7585 : : case EXEC_OACC_CACHE:
7586 : : case EXEC_OACC_ENTER_DATA:
7587 : : case EXEC_OACC_EXIT_DATA:
7588 : : case EXEC_OACC_ATOMIC:
7589 : : case EXEC_OACC_ROUTINE:
7590 : : return true;
7591 : :
7592 : 3 : default:
7593 : 3 : return false;
7594 : : }
7595 : : }
|
