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