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 24536543 : match_word (const char *str, match (*subr) (void), locus *old_locus,
87 : bool no_substring = false, bool reject_stmt_on_error = true)
88 : {
89 24536543 : match m;
90 24536543 : char c;
91 :
92 24536543 : if (str != NULL)
93 : {
94 14719561 : m = gfc_match (str);
95 14719561 : if (m != MATCH_YES)
96 : return m;
97 51505 : if (no_substring && gfc_current_form == FORM_FREE
98 3992118 : && ((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 13758918 : m = (*subr) ();
106 :
107 13758914 : if (m == MATCH_NO || (reject_stmt_on_error && m == MATCH_ERROR))
108 : {
109 9292927 : gfc_current_locus = *old_locus;
110 9292927 : 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 177228 : match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus,
123 : bool *simd_matched)
124 : {
125 177228 : match m;
126 177228 : char c;
127 :
128 177228 : if (str != NULL)
129 : {
130 177228 : m = gfc_match (str);
131 177228 : if (m != MATCH_YES)
132 : return m;
133 3991 : if (gfc_current_form == FORM_FREE
134 3991 : && ((c = gfc_peek_ascii_char ()) == '_' || c == '$' || ISALNUM (c)))
135 : {
136 0 : gfc_current_locus = *old_locus;
137 0 : return MATCH_NO;
138 : }
139 3991 : *simd_matched = true;
140 : }
141 :
142 3991 : m = (*subr) ();
143 :
144 3991 : 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 21504 : use_modules (void)
158 : {
159 21504 : gfc_error_buffer old_error;
160 :
161 21504 : gfc_push_error (&old_error);
162 21504 : gfc_buffer_error (false);
163 21504 : gfc_use_modules ();
164 21500 : gfc_buffer_error (true);
165 21500 : gfc_pop_error (&old_error);
166 21500 : gfc_commit_symbols ();
167 21500 : gfc_warning_check ();
168 21500 : gfc_current_ns->old_equiv = gfc_current_ns->equiv;
169 21500 : gfc_current_ns->old_data = gfc_current_ns->data;
170 21500 : last_was_use_stmt = false;
171 21500 : }
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 10962 : decode_specification_statement (void)
198 : {
199 10962 : gfc_statement st;
200 10962 : locus old_locus;
201 10962 : char c;
202 :
203 10962 : if (gfc_match_eos () == MATCH_YES)
204 : return ST_NONE;
205 :
206 10962 : old_locus = gfc_current_locus;
207 :
208 10962 : 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 9806 : undo_new_statement ();
216 9806 : if (last_was_use_stmt)
217 977 : use_modules ();
218 : }
219 :
220 9806 : match ("import", gfc_match_import, ST_IMPORT);
221 :
222 9293 : if (gfc_current_block ()->result->ts.type != BT_DERIVED)
223 5973 : 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 7017 : end_of_block:
334 7017 : gfc_clear_error ();
335 7017 : gfc_buffer_error (false);
336 7017 : gfc_current_locus = old_locus;
337 :
338 7017 : 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 1399190 : current_interface_valid_p ()
346 : {
347 1399190 : 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 1399190 : get_current_interface_ptr ()
370 : {
371 1399190 : 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 1399190 : decode_statement (void)
386 : {
387 1399190 : gfc_statement st;
388 1399190 : locus old_locus;
389 1399190 : match m = MATCH_NO;
390 1399190 : char c;
391 :
392 1399190 : gfc_enforce_clean_symbol_state ();
393 :
394 1399190 : gfc_clear_error (); /* Clear any pending errors. */
395 1399190 : gfc_clear_warning (); /* Clear any pending warnings. */
396 :
397 1399190 : current_interface_ptr = get_current_interface_ptr ();
398 2798380 : previous_interface_head = current_interface_ptr == nullptr
399 1399190 : ? nullptr
400 : : *current_interface_ptr;
401 :
402 1399190 : gfc_matching_function = false;
403 :
404 1399190 : if (gfc_match_eos () == MATCH_YES)
405 : return ST_NONE;
406 :
407 1399177 : if (gfc_current_state () == COMP_FUNCTION
408 100544 : && gfc_current_block ()->result->ts.kind == -1)
409 10962 : return decode_specification_statement ();
410 :
411 1388215 : old_locus = gfc_current_locus;
412 :
413 1388215 : c = gfc_peek_ascii_char ();
414 :
415 1388215 : if (c == 'u')
416 : {
417 27976 : if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
418 : {
419 23468 : last_was_use_stmt = true;
420 23468 : return ST_USE;
421 : }
422 : else
423 4508 : undo_new_statement ();
424 : }
425 :
426 1364747 : if (last_was_use_stmt)
427 20167 : 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 1364744 : if (gfc_current_state () == COMP_NONE
434 : || gfc_current_state () == COMP_INTERFACE
435 : || gfc_current_state () == COMP_CONTAINS)
436 : {
437 132152 : gfc_matching_function = true;
438 132152 : m = gfc_match_function_decl ();
439 132152 : if (m == MATCH_YES)
440 : return ST_FUNCTION;
441 111747 : else if (m == MATCH_ERROR)
442 10247 : reject_statement ();
443 : else
444 101500 : gfc_undo_symbols ();
445 111747 : gfc_current_locus = old_locus;
446 : }
447 1344339 : gfc_matching_function = false;
448 :
449 : /* Legacy parameter statements are ambiguous with assignments so try parameter
450 : first. */
451 1344339 : 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 1336524 : match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
457 1053045 : match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
458 :
459 1043538 : if (in_specification_block)
460 : {
461 429685 : m = match_word (NULL, gfc_match_st_function, &old_locus);
462 429685 : if (m == MATCH_YES)
463 : return ST_STATEMENT_FUNCTION;
464 : }
465 :
466 1043311 : if (!(in_specification_block && m == MATCH_ERROR))
467 : {
468 1043290 : match (NULL, gfc_match_ptr_fcn_assign, ST_ASSIGNMENT);
469 : }
470 :
471 1043154 : match (NULL, gfc_match_data_decl, ST_DATA_DECL);
472 824880 : 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 824624 : if (gfc_match_subroutine () == MATCH_YES)
478 : return ST_SUBROUTINE;
479 780480 : gfc_undo_symbols ();
480 780480 : gfc_current_locus = old_locus;
481 :
482 780480 : 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 780216 : gfc_undo_symbols ();
490 780216 : 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 780216 : if (gfc_match_if (&st) == MATCH_YES)
498 235870 : return st;
499 544346 : gfc_undo_symbols ();
500 544346 : gfc_current_locus = old_locus;
501 :
502 544346 : if (gfc_match_where (&st) == MATCH_YES)
503 452 : return st;
504 543894 : gfc_undo_symbols ();
505 543894 : gfc_current_locus = old_locus;
506 :
507 543894 : if (gfc_match_forall (&st) == MATCH_YES)
508 1987 : return st;
509 541907 : gfc_undo_symbols ();
510 541907 : gfc_current_locus = old_locus;
511 :
512 : /* Try to match TYPE as an alias for PRINT. */
513 541907 : if (gfc_match_type (&st) == MATCH_YES)
514 19 : return st;
515 541888 : gfc_undo_symbols ();
516 541888 : gfc_current_locus = old_locus;
517 :
518 541888 : match (NULL, gfc_match_do, ST_DO);
519 508437 : match (NULL, gfc_match_block, ST_BLOCK);
520 506907 : match (NULL, gfc_match_associate, ST_ASSOCIATE);
521 505224 : match (NULL, gfc_match_change_team, ST_CHANGE_TEAM);
522 505093 : match (NULL, gfc_match_critical, ST_CRITICAL);
523 505039 : match (NULL, gfc_match_select, ST_SELECT_CASE);
524 504489 : match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
525 501267 : 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 500219 : switch (c)
532 : {
533 15716 : case 'a':
534 15716 : match ("abstract% interface", gfc_match_abstract_interface,
535 : ST_INTERFACE);
536 15224 : 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 111521 : case 'c':
550 111521 : match ("call", gfc_match_call, ST_CALL);
551 30047 : match ("close", gfc_match_close, ST_CLOSE);
552 26887 : match ("continue", gfc_match_continue, ST_CONTINUE);
553 24069 : match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
554 24065 : match ("cycle", gfc_match_cycle, ST_CYCLE);
555 24035 : match ("case", gfc_match_case, ST_CASE);
556 22405 : match ("common", gfc_match_common, ST_COMMON);
557 20388 : match ("contains", gfc_match_eos, ST_CONTAINS);
558 2384 : match ("class", gfc_match_class_is, ST_CLASS_IS);
559 281 : match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
560 269 : break;
561 :
562 8838 : case 'd':
563 8838 : match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
564 3113 : match ("data", gfc_match_data, ST_DATA);
565 731 : match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
566 96 : break;
567 :
568 198596 : case 'e':
569 198596 : match ("end file", gfc_match_endfile, ST_END_FILE);
570 198525 : match ("exit", gfc_match_exit, ST_EXIT);
571 198227 : match ("else", gfc_match_else, ST_ELSE);
572 194080 : match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
573 193768 : match ("else if", gfc_match_elseif, ST_ELSEIF);
574 191821 : match ("error% stop", gfc_match_error_stop, ST_ERROR_STOP);
575 190849 : match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
576 :
577 190691 : if (gfc_match_end (&st) == MATCH_YES)
578 185323 : return st;
579 :
580 5368 : match ("entry% ", gfc_match_entry, ST_ENTRY);
581 4580 : match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
582 3573 : 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 1856 : case 'f':
588 1856 : match ("fail% image", gfc_match_fail_image, ST_FAIL_IMAGE);
589 1844 : match ("final", gfc_match_final_decl, ST_FINAL);
590 1361 : match ("flush", gfc_match_flush, ST_FLUSH);
591 1266 : 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 42419 : case 'i':
601 42419 : match ("inquire", gfc_match_inquire, ST_INQUIRE);
602 41489 : match ("implicit", gfc_match_implicit, ST_IMPLICIT);
603 41074 : match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
604 16494 : match ("import", gfc_match_import, ST_IMPORT);
605 12981 : 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 12076 : case 'm':
615 12076 : match ("map", gfc_match_map, ST_MAP);
616 11818 : match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC);
617 10213 : match ("module", gfc_match_module, ST_MODULE);
618 28 : break;
619 :
620 1641 : case 'n':
621 1641 : match ("nullify", gfc_match_nullify, ST_NULLIFY);
622 1064 : match ("namelist", gfc_match_namelist, ST_NAMELIST);
623 17 : break;
624 :
625 4209 : case 'o':
626 4209 : match ("open", gfc_match_open, ST_OPEN);
627 242 : match ("optional", gfc_match_optional, ST_ATTR_DECL);
628 25 : break;
629 :
630 37927 : case 'p':
631 37927 : match ("print", gfc_match_print, ST_WRITE);
632 30608 : match ("pause", gfc_match_pause, ST_PAUSE);
633 30578 : match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
634 29692 : if (gfc_match_private (&st) == MATCH_YES)
635 1629 : return st;
636 28063 : match ("procedure", gfc_match_procedure, ST_PROCEDURE);
637 21668 : match ("program", gfc_match_program, ST_PROGRAM);
638 1780 : if (gfc_match_public (&st) == MATCH_YES)
639 1521 : return st;
640 259 : match ("protected", gfc_match_protected, ST_ATTR_DECL);
641 242 : break;
642 :
643 14207 : case 'r':
644 14207 : match ("rank", gfc_match_rank_is, ST_RANK);
645 11839 : match ("read", gfc_match_read, ST_READ);
646 5267 : match ("return", gfc_match_return, ST_RETURN);
647 2445 : match ("rewind", gfc_match_rewind, ST_REWIND);
648 156 : break;
649 :
650 11618 : case 's':
651 11618 : match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL);
652 11320 : match ("sequence", gfc_match_eos, ST_SEQUENCE);
653 11080 : match ("stop", gfc_match_stop, ST_STOP);
654 2133 : match ("save", gfc_match_save, ST_ATTR_DECL);
655 1866 : match ("static", gfc_match_static, ST_ATTR_DECL);
656 1865 : match ("submodule", gfc_match_submodule, ST_SUBMODULE);
657 1600 : match ("sync% all", gfc_match_sync_all, ST_SYNC_ALL);
658 385 : match ("sync% images", gfc_match_sync_images, ST_SYNC_IMAGES);
659 242 : match ("sync% memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
660 168 : match ("sync% team", gfc_match_sync_team, ST_SYNC_TEAM);
661 120 : break;
662 :
663 17545 : case 't':
664 17545 : match ("target", gfc_match_target, ST_ATTR_DECL);
665 17450 : match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
666 3767 : 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 19202 : case 'w':
680 19202 : match ("wait", gfc_match_wait, ST_WAIT);
681 19113 : 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 2337 : 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 2335 : reject_statement ();
698 :
699 2335 : gfc_error_recovery ();
700 :
701 2335 : 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 34364 : decode_omp_directive (void)
1002 : {
1003 34364 : locus old_locus;
1004 34364 : char c;
1005 34364 : bool simd_matched = false;
1006 34364 : bool spec_only = false;
1007 34364 : gfc_statement ret = ST_NONE;
1008 34364 : bool pure_ok = true;
1009 :
1010 34364 : gfc_enforce_clean_symbol_state ();
1011 :
1012 34364 : gfc_clear_error (); /* Clear any pending errors. */
1013 34364 : gfc_clear_warning (); /* Clear any pending warnings. */
1014 :
1015 34364 : gfc_matching_function = false;
1016 :
1017 34364 : if (gfc_current_state () == COMP_FUNCTION
1018 1504 : && gfc_current_block ()->result->ts.kind == -1)
1019 34364 : spec_only = true;
1020 :
1021 34364 : 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 34364 : 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 34364 : switch (c)
1035 : {
1036 2564 : case 'a':
1037 : /* For -fopenmp-simd, ignore 'assumes'; note no clause starts with 's'. */
1038 2564 : if (!flag_openmp && gfc_match ("assumes") == MATCH_YES)
1039 : break;
1040 2562 : matcho ("assumes", gfc_match_omp_assumes, ST_OMP_ASSUMES);
1041 2517 : matchs ("assume", gfc_match_omp_assume, ST_OMP_ASSUME);
1042 2492 : break;
1043 :
1044 665 : case 'b':
1045 665 : matcho ("begin metadirective", gfc_match_omp_begin_metadirective,
1046 : ST_OMP_BEGIN_METADIRECTIVE);
1047 : break;
1048 :
1049 3638 : case 'd':
1050 3638 : matchdo ("declare mapper", gfc_match_omp_declare_mapper,
1051 : ST_OMP_DECLARE_MAPPER);
1052 3606 : matchdo ("declare_mapper", gfc_match_omp_declare_mapper,
1053 : ST_OMP_DECLARE_MAPPER);
1054 3603 : matchds ("declare reduction", gfc_match_omp_declare_reduction,
1055 : ST_OMP_DECLARE_REDUCTION);
1056 3013 : matchds ("declare_reduction", gfc_match_omp_declare_reduction,
1057 : ST_OMP_DECLARE_REDUCTION);
1058 3009 : matchds ("declare simd", gfc_match_omp_declare_simd,
1059 : ST_OMP_DECLARE_SIMD);
1060 2805 : matchds ("declare_simd", gfc_match_omp_declare_simd,
1061 : ST_OMP_DECLARE_SIMD);
1062 2801 : matchdo ("declare target", gfc_match_omp_declare_target,
1063 : ST_OMP_DECLARE_TARGET);
1064 2314 : matchdo ("declare_target", gfc_match_omp_declare_target,
1065 : ST_OMP_DECLARE_TARGET);
1066 2311 : matchdo ("declare variant", gfc_match_omp_declare_variant,
1067 : ST_OMP_DECLARE_VARIANT);
1068 1889 : matchdo ("declare_variant", gfc_match_omp_declare_variant,
1069 : ST_OMP_DECLARE_VARIANT);
1070 : break;
1071 10030 : case 'e':
1072 10030 : matchs ("end assume", gfc_match_omp_eos_error, ST_OMP_END_ASSUME);
1073 10018 : matcho ("end metadirective", gfc_match_omp_eos_error,
1074 : ST_OMP_END_METADIRECTIVE);
1075 9920 : matchs ("end simd", gfc_match_omp_eos_error, ST_OMP_END_SIMD);
1076 9868 : matchs ("end tile", gfc_match_omp_eos_error, ST_OMP_END_TILE);
1077 9822 : matchs ("end unroll", gfc_match_omp_eos_error, ST_OMP_END_UNROLL);
1078 9781 : matcho ("error", gfc_match_omp_error, ST_OMP_ERROR);
1079 : break;
1080 :
1081 350 : case 'm':
1082 350 : 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 1837 : case 's':
1090 1837 : matchs ("scan", gfc_match_omp_scan, ST_OMP_SCAN);
1091 1786 : matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
1092 981 : break;
1093 9149 : case 't':
1094 9149 : matchs ("tile", gfc_match_omp_tile, ST_OMP_TILE);
1095 8946 : break;
1096 424 : case 'u':
1097 424 : matchs ("unroll", gfc_match_omp_unroll, ST_OMP_UNROLL);
1098 0 : break;
1099 : }
1100 :
1101 30506 : pure_ok = false;
1102 30506 : 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 30490 : switch (c)
1114 : {
1115 2494 : case 'a':
1116 2494 : if (in_exec_part)
1117 2049 : matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE_EXEC);
1118 : else
1119 445 : matcho ("allocate", gfc_match_omp_allocate, ST_OMP_ALLOCATE);
1120 2218 : matcho ("allocators", gfc_match_omp_allocators, ST_OMP_ALLOCATORS);
1121 2192 : 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 677 : case 'c':
1127 677 : matcho ("cancellation% point", gfc_match_omp_cancellation_point,
1128 : ST_OMP_CANCELLATION_POINT);
1129 501 : matcho ("cancellation_point", gfc_match_omp_cancellation_point,
1130 : ST_OMP_CANCELLATION_POINT);
1131 499 : matcho ("cancel", gfc_match_omp_cancel, ST_OMP_CANCEL);
1132 175 : matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
1133 : break;
1134 1874 : case 'd':
1135 1874 : matcho ("depobj", gfc_match_omp_depobj, ST_OMP_DEPOBJ);
1136 1746 : matcho ("dispatch", gfc_match_omp_dispatch, ST_OMP_DISPATCH);
1137 1586 : matchs ("distribute parallel do simd",
1138 : gfc_match_omp_distribute_parallel_do_simd,
1139 : ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD);
1140 1552 : matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do,
1141 : ST_OMP_DISTRIBUTE_PARALLEL_DO);
1142 1505 : matchs ("distribute simd", gfc_match_omp_distribute_simd,
1143 : ST_OMP_DISTRIBUTE_SIMD);
1144 1453 : matcho ("distribute", gfc_match_omp_distribute, ST_OMP_DISTRIBUTE);
1145 1396 : matchs ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD);
1146 1257 : matcho ("do", gfc_match_omp_do, ST_OMP_DO);
1147 : break;
1148 9671 : case 'e':
1149 9671 : matcho ("end allocators", gfc_match_omp_eos_error, ST_OMP_END_ALLOCATORS);
1150 9666 : matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC);
1151 9448 : matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL);
1152 9282 : matcho ("end dispatch", gfc_match_omp_end_nowait, ST_OMP_END_DISPATCH);
1153 9276 : matchs ("end distribute parallel do simd", gfc_match_omp_eos_error,
1154 : ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD);
1155 9269 : matcho ("end distribute parallel do", gfc_match_omp_eos_error,
1156 : ST_OMP_END_DISTRIBUTE_PARALLEL_DO);
1157 9262 : matchs ("end distribute simd", gfc_match_omp_eos_error,
1158 : ST_OMP_END_DISTRIBUTE_SIMD);
1159 9255 : matcho ("end distribute", gfc_match_omp_eos_error, ST_OMP_END_DISTRIBUTE);
1160 9240 : matchs ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD);
1161 9207 : matcho ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
1162 8946 : matchs ("end loop", gfc_match_omp_eos_error, ST_OMP_END_LOOP);
1163 8942 : matcho ("end masked taskloop simd", gfc_match_omp_eos_error,
1164 : ST_OMP_END_MASKED_TASKLOOP_SIMD);
1165 8931 : matcho ("end masked taskloop", gfc_match_omp_eos_error,
1166 : ST_OMP_END_MASKED_TASKLOOP);
1167 8924 : matcho ("end masked", gfc_match_omp_eos_error, ST_OMP_END_MASKED);
1168 8870 : matcho ("end master taskloop simd", gfc_match_omp_eos_error,
1169 : ST_OMP_END_MASTER_TASKLOOP_SIMD);
1170 8865 : matcho ("end master taskloop", gfc_match_omp_eos_error,
1171 : ST_OMP_END_MASTER_TASKLOOP);
1172 8860 : matcho ("end master", gfc_match_omp_eos_error, ST_OMP_END_MASTER);
1173 8749 : matchs ("end ordered", gfc_match_omp_eos_error, ST_OMP_END_ORDERED);
1174 8510 : matchs ("end parallel do simd", gfc_match_omp_eos_error,
1175 : ST_OMP_END_PARALLEL_DO_SIMD);
1176 8468 : matcho ("end parallel do", gfc_match_omp_eos_error,
1177 : ST_OMP_END_PARALLEL_DO);
1178 8265 : matcho ("end parallel loop", gfc_match_omp_eos_error,
1179 : ST_OMP_END_PARALLEL_LOOP);
1180 8264 : matcho ("end parallel masked taskloop simd", gfc_match_omp_eos_error,
1181 : ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD);
1182 8256 : matcho ("end parallel masked taskloop", gfc_match_omp_eos_error,
1183 : ST_OMP_END_PARALLEL_MASKED_TASKLOOP);
1184 8249 : matcho ("end parallel masked", gfc_match_omp_eos_error,
1185 : ST_OMP_END_PARALLEL_MASKED);
1186 8235 : matcho ("end parallel master taskloop simd", gfc_match_omp_eos_error,
1187 : ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD);
1188 8229 : matcho ("end parallel master taskloop", gfc_match_omp_eos_error,
1189 : ST_OMP_END_PARALLEL_MASTER_TASKLOOP);
1190 8224 : matcho ("end parallel master", gfc_match_omp_eos_error,
1191 : ST_OMP_END_PARALLEL_MASTER);
1192 8210 : matcho ("end parallel sections", gfc_match_omp_eos_error,
1193 : ST_OMP_END_PARALLEL_SECTIONS);
1194 8150 : matcho ("end parallel workshare", gfc_match_omp_eos_error,
1195 : ST_OMP_END_PARALLEL_WORKSHARE);
1196 8094 : matcho ("end parallel", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL);
1197 5973 : matcho ("end scope", gfc_match_omp_end_nowait, ST_OMP_END_SCOPE);
1198 5913 : matcho ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
1199 5832 : matcho ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
1200 5262 : matcho ("end target data", gfc_match_omp_eos_error, ST_OMP_END_TARGET_DATA);
1201 3871 : matcho ("end target_data", gfc_match_omp_eos_error, ST_OMP_END_TARGET_DATA);
1202 3869 : matchs ("end target parallel do simd", gfc_match_omp_end_nowait,
1203 : ST_OMP_END_TARGET_PARALLEL_DO_SIMD);
1204 3860 : matcho ("end target parallel do", gfc_match_omp_end_nowait,
1205 : ST_OMP_END_TARGET_PARALLEL_DO);
1206 3851 : matcho ("end target parallel loop", gfc_match_omp_end_nowait,
1207 : ST_OMP_END_TARGET_PARALLEL_LOOP);
1208 3844 : matcho ("end target parallel", gfc_match_omp_end_nowait,
1209 : ST_OMP_END_TARGET_PARALLEL);
1210 3821 : matchs ("end target simd", gfc_match_omp_end_nowait, ST_OMP_END_TARGET_SIMD);
1211 3802 : 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 3782 : matcho ("end target teams distribute parallel do", gfc_match_omp_end_nowait,
1215 : ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO);
1216 3767 : matchs ("end target teams distribute simd", gfc_match_omp_end_nowait,
1217 : ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD);
1218 3758 : matcho ("end target teams distribute", gfc_match_omp_end_nowait,
1219 : ST_OMP_END_TARGET_TEAMS_DISTRIBUTE);
1220 3749 : matcho ("end target teams loop", gfc_match_omp_end_nowait,
1221 : ST_OMP_END_TARGET_TEAMS_LOOP);
1222 3741 : matcho ("end target teams", gfc_match_omp_end_nowait,
1223 : ST_OMP_END_TARGET_TEAMS);
1224 3667 : matcho ("end target", gfc_match_omp_end_nowait, ST_OMP_END_TARGET);
1225 1605 : matcho ("end taskgroup", gfc_match_omp_eos_error, ST_OMP_END_TASKGROUP);
1226 1418 : matchs ("end taskloop simd", gfc_match_omp_eos_error,
1227 : ST_OMP_END_TASKLOOP_SIMD);
1228 1406 : matcho ("end taskloop", gfc_match_omp_eos_error, ST_OMP_END_TASKLOOP);
1229 1388 : 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 101 : case 'f':
1244 101 : matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
1245 : break;
1246 51 : case 'g':
1247 51 : 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 558 : case 'o':
1271 558 : if (gfc_match ("ordered depend (") == MATCH_YES
1272 558 : || 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 239 : matchs ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
1282 : break;
1283 3961 : case 'p':
1284 3961 : matchs ("parallel do simd", gfc_match_omp_parallel_do_simd,
1285 : ST_OMP_PARALLEL_DO_SIMD);
1286 3663 : matcho ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
1287 2460 : matcho ("parallel loop", gfc_match_omp_parallel_loop,
1288 : ST_OMP_PARALLEL_LOOP);
1289 2429 : matcho ("parallel masked taskloop simd",
1290 : gfc_match_omp_parallel_masked_taskloop_simd,
1291 : ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD);
1292 2416 : matcho ("parallel masked taskloop",
1293 : gfc_match_omp_parallel_masked_taskloop,
1294 : ST_OMP_PARALLEL_MASKED_TASKLOOP);
1295 2406 : matcho ("parallel masked", gfc_match_omp_parallel_masked,
1296 : ST_OMP_PARALLEL_MASKED);
1297 2392 : matcho ("parallel master taskloop simd",
1298 : gfc_match_omp_parallel_master_taskloop_simd,
1299 : ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD);
1300 2371 : matcho ("parallel master taskloop",
1301 : gfc_match_omp_parallel_master_taskloop,
1302 : ST_OMP_PARALLEL_MASTER_TASKLOOP);
1303 2355 : matcho ("parallel master", gfc_match_omp_parallel_master,
1304 : ST_OMP_PARALLEL_MASTER);
1305 2341 : matcho ("parallel sections", gfc_match_omp_parallel_sections,
1306 : ST_OMP_PARALLEL_SECTIONS);
1307 2282 : matcho ("parallel workshare", gfc_match_omp_parallel_workshare,
1308 : ST_OMP_PARALLEL_WORKSHARE);
1309 2226 : matcho ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
1310 : break;
1311 111 : case 'r':
1312 111 : matcho ("requires", gfc_match_omp_requires, ST_OMP_REQUIRES);
1313 : break;
1314 981 : case 's':
1315 981 : matcho ("scope", gfc_match_omp_scope, ST_OMP_SCOPE);
1316 923 : matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
1317 841 : matcho ("section", gfc_match_omp_eos_error, ST_OMP_SECTION);
1318 583 : matcho ("single", gfc_match_omp_single, ST_OMP_SINGLE);
1319 : break;
1320 8940 : case 't':
1321 8940 : matcho ("target data", gfc_match_omp_target_data, ST_OMP_TARGET_DATA);
1322 7538 : matcho ("target_data", gfc_match_omp_target_data, ST_OMP_TARGET_DATA);
1323 7536 : matcho ("target enter data", gfc_match_omp_target_enter_data,
1324 : ST_OMP_TARGET_ENTER_DATA);
1325 7067 : matcho ("target_enter_data", gfc_match_omp_target_enter_data,
1326 : ST_OMP_TARGET_ENTER_DATA);
1327 7064 : matcho ("target exit data", gfc_match_omp_target_exit_data,
1328 : ST_OMP_TARGET_EXIT_DATA);
1329 6699 : matcho ("target_exit_data", gfc_match_omp_target_exit_data,
1330 : ST_OMP_TARGET_EXIT_DATA);
1331 6697 : matchs ("target parallel do simd", gfc_match_omp_target_parallel_do_simd,
1332 : ST_OMP_TARGET_PARALLEL_DO_SIMD);
1333 6677 : matcho ("target parallel do", gfc_match_omp_target_parallel_do,
1334 : ST_OMP_TARGET_PARALLEL_DO);
1335 6596 : matcho ("target parallel loop", gfc_match_omp_target_parallel_loop,
1336 : ST_OMP_TARGET_PARALLEL_LOOP);
1337 6580 : matcho ("target parallel", gfc_match_omp_target_parallel,
1338 : ST_OMP_TARGET_PARALLEL);
1339 6551 : matchs ("target simd", gfc_match_omp_target_simd, ST_OMP_TARGET_SIMD);
1340 6517 : 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 6481 : matcho ("target teams distribute parallel do",
1344 : gfc_match_omp_target_teams_distribute_parallel_do,
1345 : ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO);
1346 6415 : matchs ("target teams distribute simd",
1347 : gfc_match_omp_target_teams_distribute_simd,
1348 : ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD);
1349 6394 : matcho ("target teams distribute", gfc_match_omp_target_teams_distribute,
1350 : ST_OMP_TARGET_TEAMS_DISTRIBUTE);
1351 6375 : matcho ("target teams loop", gfc_match_omp_target_teams_loop,
1352 : ST_OMP_TARGET_TEAMS_LOOP);
1353 6357 : matcho ("target teams", gfc_match_omp_target_teams, ST_OMP_TARGET_TEAMS);
1354 6280 : matcho ("target update", gfc_match_omp_target_update,
1355 : ST_OMP_TARGET_UPDATE);
1356 4555 : matcho ("target_update", gfc_match_omp_target_update,
1357 : ST_OMP_TARGET_UPDATE);
1358 4553 : matcho ("target", gfc_match_omp_target, ST_OMP_TARGET);
1359 2291 : matcho ("taskgroup", gfc_match_omp_taskgroup, ST_OMP_TASKGROUP);
1360 2103 : matchs ("taskloop simd", gfc_match_omp_taskloop_simd,
1361 : ST_OMP_TASKLOOP_SIMD);
1362 2063 : matcho ("taskloop", gfc_match_omp_taskloop, ST_OMP_TASKLOOP);
1363 1991 : matcho ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
1364 1841 : matcho ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD);
1365 1831 : matcho ("task", gfc_match_omp_task, ST_OMP_TASK);
1366 647 : matchs ("teams distribute parallel do simd",
1367 : gfc_match_omp_teams_distribute_parallel_do_simd,
1368 : ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
1369 584 : matcho ("teams distribute parallel do",
1370 : gfc_match_omp_teams_distribute_parallel_do,
1371 : ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO);
1372 543 : matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd,
1373 : ST_OMP_TEAMS_DISTRIBUTE_SIMD);
1374 499 : matcho ("teams distribute", gfc_match_omp_teams_distribute,
1375 : ST_OMP_TEAMS_DISTRIBUTE);
1376 477 : matcho ("teams loop", gfc_match_omp_teams_loop, ST_OMP_TEAMS_LOOP);
1377 442 : 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 724 : error_handling:
1394 : /* Directive found but failed with an error, possibly with
1395 : a stored an error message. */
1396 724 : if ((flag_openmp || simd_matched) && gfc_error_check () == 0)
1397 0 : gfc_error_now ("Syntax error in statement at %C");
1398 :
1399 795 : recover:
1400 :
1401 : /* If parsing a metadirective, let the caller deal with the cleanup. */
1402 795 : if (gfc_matching_omp_context_selector)
1403 : return ST_NONE;
1404 :
1405 794 : reject_statement ();
1406 :
1407 794 : gfc_error_recovery ();
1408 :
1409 794 : return ST_NONE;
1410 :
1411 33534 : finish:
1412 33534 : if (ret == ST_OMP_ERROR && new_st.ext.omp_clauses->at == OMP_AT_EXECUTION)
1413 : {
1414 48 : gfc_unset_implicit_pure (NULL);
1415 :
1416 48 : 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 33533 : if (!pure_ok)
1426 : {
1427 29952 : gfc_unset_implicit_pure (NULL);
1428 :
1429 29952 : 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 33530 : if (ret == ST_OMP_ALLOCATE && !check_omp_allocate_stmt (&old_locus))
1439 4 : goto error_handling;
1440 :
1441 33526 : 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 7107 : case ST_OMP_DECLARE_TARGET:
1448 7107 : case ST_OMP_INTEROP:
1449 7107 : case ST_OMP_TARGET:
1450 7107 : case ST_OMP_TARGET_DATA:
1451 7107 : case ST_OMP_TARGET_ENTER_DATA:
1452 7107 : case ST_OMP_TARGET_EXIT_DATA:
1453 7107 : case ST_OMP_TARGET_TEAMS:
1454 7107 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
1455 7107 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
1456 7107 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
1457 7107 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1458 7107 : case ST_OMP_TARGET_TEAMS_LOOP:
1459 7107 : case ST_OMP_TARGET_PARALLEL:
1460 7107 : case ST_OMP_TARGET_PARALLEL_DO:
1461 7107 : case ST_OMP_TARGET_PARALLEL_DO_SIMD:
1462 7107 : case ST_OMP_TARGET_PARALLEL_LOOP:
1463 7107 : case ST_OMP_TARGET_SIMD:
1464 7107 : case ST_OMP_TARGET_UPDATE:
1465 7107 : {
1466 7107 : gfc_namespace *prog_unit = gfc_current_ns;
1467 11419 : while (prog_unit->parent)
1468 : {
1469 4320 : if (gfc_state_stack->previous
1470 4320 : && gfc_state_stack->previous->state == COMP_INTERFACE)
1471 : break;
1472 4312 : prog_unit = prog_unit->parent;
1473 : }
1474 7107 : prog_unit->omp_target_seen = true;
1475 7107 : break;
1476 : }
1477 461 : case ST_OMP_ALLOCATE_EXEC:
1478 461 : case ST_OMP_ALLOCATORS:
1479 461 : case ST_OMP_TEAMS:
1480 461 : case ST_OMP_TEAMS_DISTRIBUTE:
1481 461 : case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
1482 461 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
1483 461 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1484 461 : case ST_OMP_TEAMS_LOOP:
1485 1717 : for (gfc_state_data *stk = gfc_state_stack->previous; stk;
1486 1256 : stk = stk->previous)
1487 1256 : if (stk && stk->tail)
1488 403 : switch (stk->tail->op)
1489 : {
1490 212 : case EXEC_OMP_TARGET:
1491 212 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
1492 212 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
1493 212 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
1494 212 : case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1495 212 : case EXEC_OMP_TARGET_TEAMS_LOOP:
1496 212 : case EXEC_OMP_TARGET_PARALLEL:
1497 212 : case EXEC_OMP_TARGET_PARALLEL_DO:
1498 212 : case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
1499 212 : case EXEC_OMP_TARGET_PARALLEL_LOOP:
1500 212 : case EXEC_OMP_TARGET_SIMD:
1501 212 : 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 208 : stk->tail->ext.omp_clauses->contains_teams_construct = 1;
1505 : break;
1506 : default:
1507 : break;
1508 : }
1509 : break;
1510 78 : case ST_OMP_ERROR:
1511 78 : 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 262 : match_omp_directive (void)
1533 : {
1534 262 : return decode_omp_directive ();
1535 : }
1536 :
1537 : static gfc_statement
1538 3516286 : decode_gcc_attribute (void)
1539 : {
1540 3516286 : locus old_locus;
1541 :
1542 3516286 : gfc_enforce_clean_symbol_state ();
1543 :
1544 3516286 : gfc_clear_error (); /* Clear any pending errors. */
1545 3516286 : gfc_clear_warning (); /* Clear any pending warnings. */
1546 3516286 : old_locus = gfc_current_locus;
1547 :
1548 3516286 : match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL);
1549 3513302 : match ("unroll", gfc_match_gcc_unroll, ST_NONE);
1550 3513285 : 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 54057 : verify_token_free (const char* token, int length, bool last_was_use_stmt)
1579 : {
1580 54057 : int i;
1581 54057 : char c;
1582 :
1583 54057 : c = gfc_next_ascii_char ();
1584 324111 : for (i = 0; i < length; i++, c = gfc_next_ascii_char ())
1585 215997 : gcc_assert (c == token[i]);
1586 :
1587 54057 : gcc_assert (gfc_is_whitespace(c));
1588 54057 : gfc_gobble_whitespace ();
1589 54057 : if (last_was_use_stmt)
1590 95 : use_modules ();
1591 54057 : }
1592 :
1593 : /* Get the next statement in free form source. */
1594 :
1595 : static gfc_statement
1596 4690200 : next_free (void)
1597 : {
1598 4690200 : match m;
1599 4690200 : int i, cnt, at_bol;
1600 4690200 : char c;
1601 :
1602 4690200 : at_bol = gfc_at_bol ();
1603 4690200 : gfc_gobble_whitespace ();
1604 :
1605 4690200 : c = gfc_peek_ascii_char ();
1606 :
1607 4690200 : 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 4687874 : 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 3377047 : gfc_next_ascii_char (); /* Eat up the exclamation sign. */
1659 3377047 : c = gfc_peek_ascii_char ();
1660 :
1661 3377047 : if (c == 'g')
1662 : {
1663 3322990 : int i;
1664 :
1665 3322990 : c = gfc_next_ascii_char ();
1666 19937940 : for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
1667 13291960 : gcc_assert (c == "gcc$"[i]);
1668 :
1669 3322990 : gfc_gobble_whitespace ();
1670 3322990 : return decode_gcc_attribute ();
1671 :
1672 : }
1673 54057 : else if (c == '$')
1674 : {
1675 : /* Since both OpenMP and OpenACC directives starts with
1676 : !$ character sequence, we must check all flags combinations */
1677 54057 : if ((flag_openmp || flag_openmp_simd)
1678 33958 : && !flag_openacc)
1679 : {
1680 33727 : verify_token_free ("$omp", 4, last_was_use_stmt);
1681 33727 : 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 1313147 : 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 1313140 : 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 280681 : next_fixed (void)
1748 : {
1749 280681 : int label, digit_flag, i;
1750 280681 : locus loc;
1751 280681 : gfc_char_t c;
1752 :
1753 280681 : 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 710696 : for (i = 0; i < 5; i++)
1766 : {
1767 624684 : c = gfc_next_char_literal (NONSTRING);
1768 :
1769 624684 : 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 194621 : case '*':
1793 194621 : c = gfc_next_char_literal (NONSTRING);
1794 :
1795 194621 : if (TOLOWER (c) == 'g')
1796 : {
1797 966480 : for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
1798 773184 : gcc_assert (TOLOWER (c) == "gcc$"[i]);
1799 :
1800 193296 : 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 86012 : 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 86012 : c = gfc_next_char_literal (NONSTRING);
1863 86012 : if (c == '\n')
1864 0 : goto blank_line;
1865 :
1866 86012 : 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 238279 : do
1878 : {
1879 238279 : loc = gfc_current_locus;
1880 238279 : c = gfc_next_char_literal (NONSTRING);
1881 : }
1882 238279 : while (gfc_is_whitespace (c));
1883 :
1884 86012 : if (c == '!')
1885 0 : goto blank_line;
1886 86012 : gfc_current_locus = loc;
1887 :
1888 86012 : 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 86006 : 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 86005 : 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 1486408 : next_statement (void)
1919 : {
1920 1486408 : gfc_statement st;
1921 1486408 : locus old_locus;
1922 :
1923 1486408 : gfc_enforce_clean_symbol_state ();
1924 1486408 : gfc_save_module_list ();
1925 :
1926 1486408 : gfc_new_block = NULL;
1927 :
1928 1486408 : gfc_current_ns->old_equiv = gfc_current_ns->equiv;
1929 1486408 : gfc_current_ns->old_data = gfc_current_ns->data;
1930 5003417 : for (;;)
1931 : {
1932 5003417 : gfc_statement_label = NULL;
1933 5003417 : gfc_buffer_error (true);
1934 :
1935 5003417 : if (gfc_at_eol ())
1936 4932266 : gfc_advance_line ();
1937 :
1938 5003417 : gfc_skip_comments ();
1939 :
1940 5003417 : if (gfc_at_end ())
1941 : {
1942 : st = ST_NONE;
1943 : break;
1944 : }
1945 :
1946 4970889 : if (gfc_define_undef_line ())
1947 8 : continue;
1948 :
1949 4970881 : old_locus = gfc_current_locus;
1950 :
1951 4970881 : st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
1952 :
1953 4970872 : if (st != ST_NONE)
1954 : break;
1955 : }
1956 :
1957 1486399 : gfc_buffer_error (false);
1958 :
1959 1486399 : if (st == ST_GET_FCN_CHARACTERISTICS)
1960 : {
1961 7070 : if (gfc_statement_label != NULL)
1962 : {
1963 3 : gfc_free_st_label (gfc_statement_label);
1964 3 : gfc_statement_label = NULL;
1965 : }
1966 7070 : gfc_current_locus = old_locus;
1967 : }
1968 :
1969 1486399 : if (st != ST_NONE)
1970 1453871 : check_statement_label (st);
1971 :
1972 1486399 : 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 232954 : push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
2114 : {
2115 232954 : p->state = new_state;
2116 232954 : p->previous = gfc_state_stack;
2117 232954 : p->sym = sym;
2118 232954 : p->head = p->tail = NULL;
2119 232954 : p->do_variable = NULL;
2120 232954 : if (p->state != COMP_DO && p->state != COMP_DO_CONCURRENT)
2121 199507 : 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 232954 : gcc_assert (gfc_state_stack);
2127 232954 : p->construct = gfc_state_stack->tail;
2128 :
2129 232954 : gfc_state_stack = p;
2130 232954 : }
2131 :
2132 :
2133 : /* Pop the current state. */
2134 : static void
2135 232459 : pop_state (void)
2136 : {
2137 232459 : 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 4554178 : gfc_find_state (gfc_compile_state state)
2145 : {
2146 4554178 : gfc_state_data *p;
2147 :
2148 18309573 : for (p = gfc_state_stack; p; p = p->previous)
2149 13858006 : if (p->state == state)
2150 : break;
2151 :
2152 4554178 : return p != NULL;
2153 : }
2154 :
2155 :
2156 : /* Starts a new level in the statement list. */
2157 :
2158 : static gfc_code *
2159 77001 : new_level (gfc_code *q)
2160 : {
2161 77001 : gfc_code *p;
2162 :
2163 77001 : p = q->block = gfc_get_code (EXEC_NOP);
2164 :
2165 77001 : gfc_state_stack->head = gfc_state_stack->tail = p;
2166 :
2167 77001 : 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 868445 : add_statement (void)
2176 : {
2177 868445 : gfc_code *p;
2178 :
2179 868445 : p = XCNEW (gfc_code);
2180 868445 : *p = new_st;
2181 :
2182 868445 : p->loc = gfc_current_locus;
2183 :
2184 868445 : if (gfc_state_stack->head == NULL)
2185 105481 : gfc_state_stack->head = p;
2186 : else
2187 762964 : gfc_state_stack->tail->next = p;
2188 :
2189 868998 : while (p->next != NULL)
2190 : p = p->next;
2191 :
2192 868445 : gfc_state_stack->tail = p;
2193 :
2194 868445 : gfc_clear_new_st ();
2195 :
2196 868445 : return p;
2197 : }
2198 :
2199 :
2200 : /* Frees everything associated with the current statement. */
2201 :
2202 : static void
2203 29121762 : undo_new_statement (void)
2204 : {
2205 29121762 : gfc_free_statements (new_st.block);
2206 29121762 : gfc_free_statements (new_st.next);
2207 29121762 : gfc_free_statement (&new_st);
2208 29121762 : gfc_clear_new_st ();
2209 29121762 : }
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 1453871 : check_statement_label (gfc_statement st)
2217 : {
2218 1453871 : gfc_sl_type type;
2219 :
2220 1453871 : if (gfc_statement_label == NULL)
2221 : {
2222 1449119 : 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 1045285 : gfc_enclosing_unit (gfc_compile_state * result)
2272 : {
2273 1045285 : gfc_state_data *p;
2274 :
2275 1515301 : for (p = gfc_state_stack; p; p = p->previous)
2276 1469619 : 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 999603 : if (result != NULL)
2282 3217 : *result = p->state;
2283 : return p;
2284 : }
2285 :
2286 45682 : 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 30212 : gfc_ascii_statement (gfc_statement st, bool strip_sentinel)
2297 : {
2298 30212 : const char *p;
2299 :
2300 30212 : 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 2964 : case ST_END_SUBROUTINE:
2444 2964 : p = "END SUBROUTINE";
2445 2964 : 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 24738 : case ST_IMPLICIT:
2496 24738 : p = "IMPLICIT";
2497 24738 : 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 30212 : 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 28596 : main_program_symbol (gfc_namespace *ns, const char *name)
3197 : {
3198 28596 : gfc_symbol *main_program;
3199 28596 : symbol_attribute attr;
3200 :
3201 28596 : gfc_get_symbol (name, ns, &main_program);
3202 28596 : gfc_clear_attr (&attr);
3203 28596 : attr.flavor = FL_PROGRAM;
3204 28596 : attr.proc = PROC_UNKNOWN;
3205 28596 : attr.subroutine = 1;
3206 28596 : attr.access = ACCESS_PUBLIC;
3207 28596 : attr.is_main_program = 1;
3208 28596 : main_program->attr = attr;
3209 28596 : main_program->declared_at = gfc_current_locus;
3210 28596 : ns->proc_name = main_program;
3211 28596 : gfc_commit_symbols ();
3212 28596 : }
3213 :
3214 :
3215 : /* Do whatever is necessary to accept the last statement. */
3216 :
3217 : static void
3218 1418361 : accept_statement (gfc_statement st)
3219 : {
3220 1418361 : switch (st)
3221 : {
3222 : case ST_IMPLICIT_NONE:
3223 : case ST_IMPLICIT:
3224 : break;
3225 :
3226 75260 : case ST_FUNCTION:
3227 75260 : case ST_SUBROUTINE:
3228 75260 : case ST_MODULE:
3229 75260 : case ST_SUBMODULE:
3230 75260 : gfc_current_ns->proc_name = gfc_new_block;
3231 75260 : 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 19939 : case ST_ENDIF:
3246 19939 : case ST_END_SELECT:
3247 19939 : case ST_END_CRITICAL:
3248 19939 : 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 3198 : case ST_END_BLOCK:
3259 3198 : case ST_END_ASSOCIATE:
3260 3198 : 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 78450 : case ST_END_PROGRAM:
3272 78450 : case ST_END_FUNCTION:
3273 78450 : case ST_END_SUBROUTINE:
3274 78450 : 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 78394 : new_st.op = EXEC_END_PROCEDURE;
3306 78394 : add_statement ();
3307 : }
3308 :
3309 : break;
3310 :
3311 773850 : case ST_ENTRY:
3312 773850 : case ST_OMP_METADIRECTIVE:
3313 773850 : case ST_OMP_BEGIN_METADIRECTIVE:
3314 773850 : case ST_CHANGE_TEAM:
3315 773850 : case ST_END_TEAM:
3316 773850 : case_executable:
3317 773850 : case_exec_markers:
3318 773850 : add_statement ();
3319 773850 : break;
3320 :
3321 : default:
3322 : break;
3323 : }
3324 :
3325 1418361 : gfc_commit_symbols ();
3326 1418361 : gfc_warning_check ();
3327 1418361 : gfc_clear_new_st ();
3328 1418361 : }
3329 :
3330 :
3331 : /* Undo anything tentative that has been built for the current statement. */
3332 :
3333 : static void
3334 9307431 : reject_statement (void)
3335 : {
3336 9307431 : gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv);
3337 9307431 : gfc_current_ns->equiv = gfc_current_ns->old_equiv;
3338 9307431 : gfc_drop_interface_elements_before (current_interface_ptr,
3339 : previous_interface_head);
3340 :
3341 9307431 : gfc_reject_data (gfc_current_ns);
3342 :
3343 : /* Don't queue use-association of a module if we reject the use statement. */
3344 9307431 : gfc_restore_old_module_list ();
3345 :
3346 9307431 : gfc_new_block = NULL;
3347 9307431 : gfc_undo_symbols ();
3348 9307431 : gfc_clear_warning ();
3349 9307431 : undo_new_statement ();
3350 9307431 : }
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 458550 : verify_st_order (st_state *p, gfc_statement st, bool silent)
3422 : {
3423 :
3424 458550 : switch (st)
3425 : {
3426 118668 : case ST_NONE:
3427 118668 : p->state = ORDER_START;
3428 118668 : in_exec_part = false;
3429 118668 : break;
3430 :
3431 25776 : case ST_USE:
3432 25776 : if (p->state > ORDER_USE)
3433 0 : goto order;
3434 25776 : p->state = ORDER_USE;
3435 25776 : break;
3436 :
3437 4536 : case ST_IMPORT:
3438 4536 : if (p->state > ORDER_IMPORT)
3439 0 : goto order;
3440 4536 : p->state = ORDER_IMPORT;
3441 4536 : break;
3442 :
3443 25389 : case ST_IMPLICIT_NONE:
3444 25389 : 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 25389 : p->state = ORDER_IMPLICIT_NONE;
3453 25389 : break;
3454 :
3455 13640 : case ST_IMPLICIT:
3456 13640 : if (p->state > ORDER_IMPLICIT)
3457 10515 : 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 2358 : case ST_DATA:
3475 2358 : if (p->state < ORDER_SPEC)
3476 17 : p->state = ORDER_SPEC;
3477 : break;
3478 :
3479 256118 : case ST_PUBLIC:
3480 256118 : case ST_PRIVATE:
3481 256118 : case ST_STRUCTURE_DECL:
3482 256118 : case ST_DERIVED_DECL:
3483 256118 : case_decl:
3484 256118 : if (p->state >= ORDER_EXEC)
3485 0 : goto order;
3486 256118 : if (p->state < ORDER_SPEC)
3487 102034 : p->state = ORDER_SPEC;
3488 : break;
3489 :
3490 2994 : 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 2994 : 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 448031 : p->where = gfc_current_locus;
3513 448031 : p->last_statement = st;
3514 448031 : return true;
3515 :
3516 10515 : order:
3517 10515 : 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 2329 : parse_derived_contains (void)
3557 : {
3558 2329 : gfc_state_data s;
3559 2329 : bool seen_private = false;
3560 2329 : bool seen_comps = false;
3561 2329 : bool error_flag = false;
3562 2329 : bool to_finish;
3563 :
3564 2329 : gcc_assert (gfc_current_state () == COMP_DERIVED);
3565 2329 : gcc_assert (gfc_current_block ());
3566 :
3567 : /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
3568 : section. */
3569 2329 : 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 2329 : 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 2329 : accept_statement (ST_CONTAINS);
3577 2329 : push_state (&s, COMP_DERIVED_CONTAINS, NULL);
3578 :
3579 2329 : gfc_typebound_default_access = ACCESS_PUBLIC;
3580 :
3581 2329 : to_finish = false;
3582 2329 : while (!to_finish)
3583 : {
3584 7015 : gfc_statement st;
3585 7015 : st = next_statement ();
3586 7015 : 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 483 : case ST_FINAL:
3613 483 : if (!gfc_notify_std (GFC_STD_F2003, "FINAL procedure declaration"
3614 : " at %C"))
3615 1 : goto error;
3616 :
3617 482 : accept_statement (ST_FINAL);
3618 482 : seen_comps = true;
3619 482 : break;
3620 :
3621 2329 : case ST_END_TYPE:
3622 2329 : to_finish = true;
3623 :
3624 2329 : if (!seen_comps
3625 2329 : && (!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 7007 : continue;
3672 :
3673 8 : error:
3674 8 : error_flag = true;
3675 8 : reject_statement ();
3676 7007 : }
3677 :
3678 2329 : pop_state ();
3679 2329 : gcc_assert (gfc_current_state () == COMP_DERIVED);
3680 :
3681 2329 : 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 21882 : check_component (gfc_symbol *sym, gfc_component *c, gfc_component **lockp,
3690 : gfc_component **eventp)
3691 : {
3692 21882 : bool coarray, lock_type, event_type, allocatable, pointer;
3693 21882 : coarray = lock_type = event_type = allocatable = pointer = false;
3694 21882 : gfc_component *lock_comp = NULL, *event_comp = NULL;
3695 :
3696 21882 : if (lockp) lock_comp = *lockp;
3697 21882 : if (eventp) event_comp = *eventp;
3698 :
3699 : /* Look for allocatable components. */
3700 21882 : if (c->attr.allocatable
3701 18598 : || (c->ts.type == BT_CLASS && c->attr.class_ok
3702 912 : && CLASS_DATA (c)->attr.allocatable)
3703 17996 : || (c->ts.type == BT_DERIVED && !c->attr.pointer
3704 3276 : && c->ts.u.derived->attr.alloc_comp))
3705 : {
3706 4476 : allocatable = true;
3707 4476 : sym->attr.alloc_comp = 1;
3708 : }
3709 :
3710 : /* Look for pointer components. */
3711 21882 : if (c->attr.pointer
3712 20545 : || (c->ts.type == BT_CLASS && c->attr.class_ok
3713 912 : && CLASS_DATA (c)->attr.class_pointer)
3714 20235 : || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
3715 : {
3716 1874 : pointer = true;
3717 1874 : sym->attr.pointer_comp = 1;
3718 : }
3719 :
3720 : /* Look for procedure pointer components. */
3721 21882 : if (c->attr.proc_pointer
3722 21444 : || (c->ts.type == BT_DERIVED
3723 4588 : && c->ts.u.derived->attr.proc_pointer_comp))
3724 522 : sym->attr.proc_pointer_comp = 1;
3725 :
3726 : /* Looking for coarray components. */
3727 21882 : if (c->attr.codimension
3728 21791 : || (c->ts.type == BT_CLASS && c->attr.class_ok
3729 912 : && CLASS_DATA (c)->attr.codimension))
3730 : {
3731 113 : coarray = true;
3732 113 : sym->attr.coarray_comp = 1;
3733 : }
3734 :
3735 21882 : 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 21882 : if ((c->ts.type == BT_DERIVED
3744 4595 : && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
3745 19 : && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
3746 21863 : || (c->ts.type == BT_CLASS && c->attr.class_ok
3747 912 : && 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 21863 : || (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 21882 : if ((c->ts.type == BT_DERIVED
3761 4595 : && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
3762 19 : && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
3763 21882 : || (c->ts.type == BT_CLASS && c->attr.class_ok
3764 912 : && 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 21882 : || (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 21882 : 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 21881 : 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 21882 : 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 21882 : 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 21882 : 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 21882 : 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 21882 : 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 21882 : 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 21882 : 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 21882 : 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 21882 : 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 21882 : if (sym->component_access == ACCESS_PRIVATE
3852 21405 : || c->attr.access == ACCESS_PRIVATE
3853 21265 : || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
3854 910 : sym->attr.private_comp = 1;
3855 :
3856 21882 : if (lockp) *lockp = lock_comp;
3857 21882 : if (eventp) *eventp = event_comp;
3858 21882 : }
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 13707 : parse_derived (void)
4038 : {
4039 13707 : int compiling_type, seen_private, seen_sequence, seen_component;
4040 13707 : gfc_statement st;
4041 13707 : gfc_state_data s;
4042 13707 : gfc_symbol *sym;
4043 13707 : gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
4044 13707 : bool pdt_parameters;
4045 :
4046 13707 : accept_statement (ST_DERIVED_DECL);
4047 13707 : push_state (&s, COMP_DERIVED, gfc_new_block);
4048 :
4049 13707 : gfc_new_block->component_access = ACCESS_PUBLIC;
4050 13707 : seen_private = 0;
4051 13707 : seen_sequence = 0;
4052 13707 : seen_component = 0;
4053 13707 : pdt_parameters = false;
4054 :
4055 13707 : compiling_type = 1;
4056 :
4057 :
4058 13707 : while (compiling_type)
4059 : {
4060 31909 : st = next_statement ();
4061 31909 : switch (st)
4062 : {
4063 0 : case ST_NONE:
4064 0 : unexpected_eof ();
4065 :
4066 17628 : case ST_DATA_DECL:
4067 17628 : case ST_PROCEDURE:
4068 17628 : accept_statement (st);
4069 17628 : 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 49382 : for (c = gfc_current_block ()->components; c; c = c->next)
4075 31756 : if (!c->next && (c->attr.pdt_kind || c->attr.pdt_len))
4076 : {
4077 786 : pdt_parameters = true;
4078 786 : 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 785 : 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 30970 : 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 13707 : case ST_END_TYPE:
4102 13707 : endType:
4103 13707 : compiling_type = 0;
4104 :
4105 13707 : if (!seen_component)
4106 1631 : gfc_notify_std (GFC_STD_F2003, "Derived type "
4107 : "definition at %C without components");
4108 :
4109 13707 : accept_statement (ST_END_TYPE);
4110 13707 : 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 2329 : case ST_CONTAINS:
4162 2329 : gfc_notify_std (GFC_STD_F2003,
4163 : "CONTAINS block in derived type"
4164 : " definition at %C");
4165 :
4166 2329 : accept_statement (ST_CONTAINS);
4167 2329 : parse_derived_contains ();
4168 2329 : 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 13707 : sym = gfc_current_block ();
4180 34183 : for (c = sym->components; c; c = c->next)
4181 20476 : check_component (sym, c, &lock_comp, &event_comp);
4182 :
4183 13707 : if (!seen_component)
4184 1631 : sym->attr.zero_comp = 1;
4185 :
4186 13707 : pop_state ();
4187 13707 : }
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 11382 : parse_interface (void)
4243 : {
4244 11382 : gfc_compile_state new_state = COMP_NONE, current_state;
4245 11382 : gfc_symbol *prog_unit, *sym;
4246 11382 : gfc_interface_info save;
4247 11382 : gfc_state_data s1, s2;
4248 11382 : gfc_statement st;
4249 :
4250 11382 : accept_statement (ST_INTERFACE);
4251 :
4252 11382 : current_interface.ns = gfc_current_ns;
4253 11382 : save = current_interface;
4254 :
4255 4445 : sym = (current_interface.type == INTERFACE_GENERIC
4256 7093 : || current_interface.type == INTERFACE_USER_OP)
4257 11382 : ? gfc_new_block : NULL;
4258 :
4259 11382 : push_state (&s1, COMP_INTERFACE, sym);
4260 11382 : current_state = COMP_NONE;
4261 :
4262 18088 : loop:
4263 29470 : gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
4264 :
4265 29470 : st = next_statement ();
4266 29470 : switch (st)
4267 : {
4268 2 : case ST_NONE:
4269 2 : unexpected_eof ();
4270 :
4271 14923 : case ST_SUBROUTINE:
4272 14923 : case ST_FUNCTION:
4273 14923 : if (st == ST_SUBROUTINE)
4274 : new_state = COMP_SUBROUTINE;
4275 6611 : else if (st == ST_FUNCTION)
4276 6611 : new_state = COMP_FUNCTION;
4277 14923 : 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 14923 : 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 14921 : if (gfc_new_block->attr.module_procedure)
4292 518 : gfc_current_ns->has_import_set = 1;
4293 14921 : 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 11379 : case ST_END_INTERFACE:
4303 11379 : gfc_free_namespace (gfc_current_ns);
4304 11379 : gfc_current_ns = current_interface.ns;
4305 11379 : 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 14921 : 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 14921 : if (current_interface.type == INTERFACE_ABSTRACT)
4330 : {
4331 510 : gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
4332 510 : 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 14921 : push_state (&s2, new_state, gfc_new_block);
4339 14921 : accept_statement (st);
4340 14921 : prog_unit = gfc_new_block;
4341 14921 : prog_unit->formal_ns = gfc_current_ns;
4342 :
4343 14922 : decl:
4344 : /* Read data declaration statements. */
4345 14922 : st = parse_spec (ST_NONE);
4346 14921 : 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 14921 : if (new_state == COMP_FUNCTION)
4352 : {
4353 6609 : if (prog_unit->result == prog_unit
4354 6011 : && prog_unit->ts.type == BT_UNKNOWN)
4355 44 : gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
4356 6565 : else if (prog_unit->result != prog_unit
4357 598 : && 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 14921 : 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 14920 : if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
4372 14180 : gfc_add_external (&prog_unit->attr, &gfc_current_locus);
4373 :
4374 14920 : current_interface = save;
4375 14920 : gfc_add_interface (prog_unit);
4376 14920 : pop_state ();
4377 :
4378 14920 : if (current_interface.ns
4379 14920 : && current_interface.ns->proc_name
4380 14920 : && 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 14920 : goto loop;
4387 :
4388 11379 : done:
4389 11379 : pop_state ();
4390 11379 : }
4391 :
4392 :
4393 : /* Associate function characteristics by going back to the function
4394 : declaration and rematching the prefix. */
4395 :
4396 : static match
4397 7070 : match_deferred_characteristics (gfc_typespec * ts)
4398 : {
4399 7070 : locus loc;
4400 7070 : match m = MATCH_ERROR;
4401 7070 : char name[GFC_MAX_SYMBOL_LEN + 1];
4402 :
4403 7070 : loc = gfc_current_locus;
4404 :
4405 7070 : gfc_current_locus = gfc_current_block ()->declared_at;
4406 :
4407 7070 : gfc_clear_error ();
4408 7070 : gfc_buffer_error (true);
4409 7070 : m = gfc_match_prefix (ts);
4410 7070 : gfc_buffer_error (false);
4411 :
4412 7070 : if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
4413 : {
4414 1060 : ts->kind = 0;
4415 :
4416 1060 : if (!ts->u.derived)
4417 7070 : m = MATCH_ERROR;
4418 : }
4419 :
4420 : /* Only permit one go at the characteristic association. */
4421 7070 : 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 7070 : if (m == MATCH_YES
4427 7055 : && gfc_match ("function% %n", name) == MATCH_YES
4428 14123 : && strcmp (name, gfc_current_block ()->name) == 0)
4429 : {
4430 7040 : gfc_current_block ()->declared_at = gfc_current_locus;
4431 7040 : gfc_commit_symbols ();
4432 : }
4433 : else
4434 : {
4435 30 : gfc_error_check ();
4436 30 : gfc_undo_symbols ();
4437 : }
4438 :
4439 7070 : gfc_current_locus =loc;
4440 7070 : 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 11630 : check_function_result_typed (void)
4451 : {
4452 11630 : gfc_typespec ts;
4453 :
4454 11630 : gcc_assert (gfc_current_state () == COMP_FUNCTION);
4455 :
4456 11630 : if (!gfc_current_ns->proc_name->result)
4457 : return true;
4458 :
4459 11630 : 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 11630 : if (ts.type == BT_CHARACTER && ts.u.cl && ts.u.cl->length)
4464 : {
4465 : /* Reject invalid type of specification expression for length. */
4466 593 : if (ts.u.cl->length->ts.type != BT_INTEGER)
4467 : return false;
4468 :
4469 414 : 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 105472 : parse_spec (gfc_statement st)
4481 : {
4482 105472 : st_state ss;
4483 105472 : bool function_result_typed = false;
4484 105472 : bool bad_characteristic = false;
4485 105472 : gfc_typespec *ts;
4486 :
4487 105472 : in_specification_block = true;
4488 :
4489 105472 : verify_st_order (&ss, ST_NONE, false);
4490 105472 : if (st == ST_NONE)
4491 96354 : 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 105471 : if (gfc_current_state () != COMP_FUNCTION)
4496 105471 : function_result_typed = true;
4497 : else
4498 : {
4499 20520 : gfc_symbol* proc = gfc_current_ns->proc_name;
4500 20520 : gcc_assert (proc);
4501 :
4502 20520 : if (proc->result && proc->result->ts.type == BT_UNKNOWN)
4503 93961 : function_result_typed = true;
4504 : }
4505 :
4506 105471 : 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 426265 : if (gfc_current_state () == COMP_BLOCK)
4513 2476 : 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 423789 : 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 426265 : if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
4566 : {
4567 13497 : bool verify_now = false;
4568 :
4569 13497 : if (st == ST_END_FUNCTION || st == ST_CONTAINS)
4570 : verify_now = true;
4571 : else
4572 : {
4573 13196 : st_state dummyss;
4574 13196 : verify_st_order (&dummyss, ST_NONE, false);
4575 13196 : verify_st_order (&dummyss, st, false);
4576 :
4577 13196 : if (!verify_st_order (&dummyss, ST_IMPLICIT, true))
4578 10514 : verify_now = true;
4579 : }
4580 :
4581 13196 : if (verify_now)
4582 10815 : function_result_typed = check_function_result_typed ();
4583 : }
4584 :
4585 426265 : switch (st)
4586 : {
4587 12 : case ST_NONE:
4588 12 : unexpected_eof ();
4589 :
4590 25018 : case ST_IMPLICIT_NONE:
4591 25018 : case ST_IMPLICIT:
4592 25018 : if (!function_result_typed)
4593 815 : function_result_typed = check_function_result_typed ();
4594 25018 : goto declSt;
4595 :
4596 2849 : case ST_FORMAT:
4597 2849 : case ST_ENTRY:
4598 2849 : case ST_DATA: /* Not allowed in interfaces */
4599 2849 : if (gfc_current_state () == COMP_INTERFACE)
4600 : break;
4601 :
4602 : /* Fall through */
4603 :
4604 313490 : case ST_USE:
4605 313490 : case ST_IMPORT:
4606 313490 : case ST_PARAMETER:
4607 313490 : case ST_PUBLIC:
4608 313490 : case ST_PRIVATE:
4609 313490 : case ST_STRUCTURE_DECL:
4610 313490 : case ST_DERIVED_DECL:
4611 313490 : case_decl:
4612 313490 : case_omp_decl:
4613 2849 : declSt:
4614 313490 : if (!verify_st_order (&ss, st, false))
4615 : {
4616 1 : reject_statement ();
4617 1 : st = next_statement ();
4618 1 : goto loop;
4619 : }
4620 :
4621 313489 : switch (st)
4622 : {
4623 11382 : case ST_INTERFACE:
4624 11382 : parse_interface ();
4625 11382 : break;
4626 :
4627 292 : case ST_STRUCTURE_DECL:
4628 292 : parse_struct_map (ST_STRUCTURE_DECL);
4629 292 : break;
4630 :
4631 13707 : case ST_DERIVED_DECL:
4632 13707 : parse_derived ();
4633 13707 : 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 313486 : accept_statement (st);
4671 313486 : st = next_statement ();
4672 313482 : 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 7070 : case ST_GET_FCN_CHARACTERISTICS:
4686 : /* This statement triggers the association of a function's result
4687 : characteristics. */
4688 7070 : ts = &gfc_current_block ()->result->ts;
4689 7070 : if (match_deferred_characteristics (ts) != MATCH_YES)
4690 15 : bad_characteristic = true;
4691 :
4692 7070 : st = next_statement ();
4693 7070 : goto loop;
4694 :
4695 : default:
4696 : break;
4697 : }
4698 :
4699 : /* If match_deferred_characteristics failed, then there is an error. */
4700 105450 : 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 105450 : in_specification_block = false;
4719 :
4720 105450 : 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 15069 : parse_if_block (void)
4868 : {
4869 15069 : gfc_code *top, *d;
4870 15069 : gfc_statement st;
4871 15069 : locus else_locus;
4872 15069 : gfc_state_data s;
4873 15069 : int seen_else;
4874 :
4875 15069 : seen_else = 0;
4876 15069 : accept_statement (ST_IF_BLOCK);
4877 :
4878 15069 : top = gfc_state_stack->tail;
4879 15069 : push_state (&s, COMP_IF, gfc_new_block);
4880 :
4881 15069 : new_st.op = EXEC_IF;
4882 15069 : d = add_statement ();
4883 :
4884 15069 : d->expr1 = top->expr1;
4885 15069 : top->expr1 = NULL;
4886 15069 : top->block = d;
4887 :
4888 21164 : do
4889 : {
4890 21164 : st = parse_executable (ST_NONE);
4891 :
4892 21163 : switch (st)
4893 : {
4894 0 : case ST_NONE:
4895 0 : unexpected_eof ();
4896 :
4897 1947 : case ST_ELSEIF:
4898 1947 : 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 1947 : d = new_level (gfc_state_stack->head);
4908 1947 : d->op = EXEC_IF;
4909 1947 : d->expr1 = new_st.expr1;
4910 :
4911 1947 : accept_statement (st);
4912 :
4913 1947 : break;
4914 :
4915 4145 : case ST_ELSE:
4916 4145 : 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 4145 : seen_else = 1;
4925 4145 : else_locus = gfc_current_locus;
4926 :
4927 4145 : d = new_level (gfc_state_stack->head);
4928 4145 : d->op = EXEC_IF;
4929 :
4930 4145 : accept_statement (st);
4931 :
4932 4145 : break;
4933 :
4934 : case ST_ENDIF:
4935 : break;
4936 :
4937 3 : default:
4938 3 : unexpected_statement (st);
4939 3 : break;
4940 : }
4941 : }
4942 21163 : while (st != ST_ENDIF);
4943 :
4944 15068 : pop_state ();
4945 15068 : accept_statement (st);
4946 15068 : }
4947 :
4948 :
4949 : /* Parse a SELECT block. */
4950 :
4951 : static void
4952 550 : parse_select_block (void)
4953 : {
4954 550 : gfc_statement st;
4955 550 : gfc_code *cp;
4956 550 : gfc_state_data s;
4957 :
4958 550 : accept_statement (ST_SELECT_CASE);
4959 :
4960 550 : cp = gfc_state_stack->tail;
4961 550 : push_state (&s, COMP_SELECT, gfc_new_block);
4962 :
4963 : /* Make sure that the next statement is a CASE or END SELECT. */
4964 552 : for (;;)
4965 : {
4966 551 : st = next_statement ();
4967 551 : if (st == ST_NONE)
4968 0 : unexpected_eof ();
4969 551 : 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 537 : 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 536 : cp = new_level (cp);
4987 536 : *cp = new_st;
4988 :
4989 536 : accept_statement (st);
4990 :
4991 1630 : do
4992 : {
4993 1630 : st = parse_executable (ST_NONE);
4994 1630 : switch (st)
4995 : {
4996 0 : case ST_NONE:
4997 0 : unexpected_eof ();
4998 :
4999 1094 : case ST_CASE:
5000 1094 : cp = new_level (gfc_state_stack->head);
5001 1094 : *cp = new_st;
5002 1094 : gfc_clear_new_st ();
5003 :
5004 1094 : 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 1630 : while (st != ST_END_SELECT);
5018 :
5019 536 : pop_state ();
5020 536 : accept_statement (st);
5021 : }
5022 :
5023 :
5024 : /* Pop the current selector from the SELECT TYPE stack. */
5025 :
5026 : static void
5027 4267 : select_type_pop (void)
5028 : {
5029 4267 : gfc_select_type_stack *old = select_type_stack;
5030 4267 : select_type_stack = old->prev;
5031 4267 : free (old);
5032 4267 : }
5033 :
5034 :
5035 : /* Parse a SELECT TYPE construct (F03:R821). */
5036 :
5037 : static void
5038 3221 : parse_select_type_block (void)
5039 : {
5040 3221 : gfc_statement st;
5041 3221 : gfc_code *cp;
5042 3221 : gfc_state_data s;
5043 :
5044 3221 : gfc_current_ns = new_st.ext.block.ns;
5045 3221 : accept_statement (ST_SELECT_TYPE);
5046 :
5047 3221 : cp = gfc_state_stack->tail;
5048 3221 : 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 3231 : for (;;)
5053 : {
5054 3226 : st = next_statement ();
5055 3226 : if (st == ST_NONE)
5056 2 : unexpected_eof ();
5057 3224 : if (st == ST_END_SELECT)
5058 : /* Empty SELECT CASE is OK. */
5059 23 : goto done;
5060 3201 : 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 3196 : cp = new_level (cp);
5071 3196 : *cp = new_st;
5072 :
5073 3196 : accept_statement (st);
5074 :
5075 5717 : do
5076 : {
5077 5717 : st = parse_executable (ST_NONE);
5078 5717 : switch (st)
5079 : {
5080 0 : case ST_NONE:
5081 0 : unexpected_eof ();
5082 :
5083 2521 : case ST_TYPE_IS:
5084 2521 : case ST_CLASS_IS:
5085 2521 : cp = new_level (gfc_state_stack->head);
5086 2521 : *cp = new_st;
5087 2521 : gfc_clear_new_st ();
5088 :
5089 2521 : 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 5717 : while (st != ST_END_SELECT);
5103 :
5104 3196 : done:
5105 3219 : pop_state ();
5106 3219 : accept_statement (st);
5107 3219 : gfc_current_ns = gfc_current_ns->parent;
5108 3219 : select_type_pop ();
5109 3219 : }
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 361877 : gfc_check_do_variable (gfc_symtree *st)
5194 : {
5195 361877 : gfc_state_data *s;
5196 :
5197 361877 : if (!st)
5198 : return 0;
5199 :
5200 1610456 : for (s=gfc_state_stack; s; s = s->previous)
5201 1248592 : 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 944383 : check_do_closure (void)
5218 : {
5219 944383 : gfc_state_data *p;
5220 :
5221 944383 : 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 15591 : gfc_build_block_ns (gfc_namespace *parent_ns)
5325 : {
5326 15591 : gfc_namespace* my_ns;
5327 15591 : static int numblock = 1;
5328 :
5329 15591 : my_ns = gfc_get_namespace (parent_ns, 1);
5330 15591 : 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 15591 : if (gfc_new_block)
5338 142 : my_ns->proc_name = gfc_new_block;
5339 : else
5340 : {
5341 15449 : bool t;
5342 15449 : char buffer[20]; /* Enough to hold "block@2147483648\n". */
5343 :
5344 15449 : snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
5345 15449 : gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
5346 30898 : t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
5347 15449 : my_ns->proc_name->name, NULL);
5348 15449 : gcc_assert (t);
5349 15449 : gfc_commit_symbol (my_ns->proc_name);
5350 : }
5351 :
5352 15591 : if (parent_ns->proc_name)
5353 15588 : my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
5354 :
5355 15591 : return my_ns;
5356 : }
5357 :
5358 :
5359 : /* Parse a BLOCK construct. */
5360 :
5361 : static void
5362 1121 : parse_block_construct (void)
5363 : {
5364 1121 : gfc_namespace* my_ns;
5365 1121 : gfc_namespace* my_parent;
5366 1121 : gfc_state_data s;
5367 :
5368 1121 : gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
5369 :
5370 1121 : my_ns = gfc_build_block_ns (gfc_current_ns);
5371 :
5372 1121 : new_st.op = EXEC_BLOCK;
5373 1121 : new_st.ext.block.ns = my_ns;
5374 1121 : new_st.ext.block.assoc = NULL;
5375 1121 : accept_statement (ST_BLOCK);
5376 :
5377 1121 : push_state (&s, COMP_BLOCK, my_ns->proc_name);
5378 1121 : gfc_current_ns = my_ns;
5379 1121 : my_parent = my_ns->parent;
5380 :
5381 1121 : 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 1112 : gfc_current_ns = my_parent;
5386 :
5387 1112 : pop_state ();
5388 1112 : }
5389 :
5390 : static void
5391 1686 : move_associates_to_block ()
5392 : {
5393 1686 : gfc_association_list *a;
5394 1686 : gfc_array_spec *as;
5395 :
5396 3532 : for (a = new_st.ext.block.assoc; a; a = a->next)
5397 : {
5398 1846 : gfc_symbol *sym, *tsym;
5399 1846 : gfc_expr *target;
5400 1846 : int rank, corank;
5401 :
5402 1846 : if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
5403 0 : gcc_unreachable ();
5404 :
5405 1846 : sym = a->st->n.sym;
5406 1846 : sym->attr.flavor = FL_VARIABLE;
5407 1846 : sym->assoc = a;
5408 1846 : sym->declared_at = a->where;
5409 1846 : 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 1846 : 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 1846 : sym->ts = a->target->ts;
5428 1846 : 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 1846 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
5442 240 : && !(sym->ts.u.cl->length
5443 92 : && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT))
5444 160 : 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 1846 : if (target->expr_type == EXPR_FUNCTION && target->symtree
5449 458 : && target->symtree->n.sym)
5450 : {
5451 458 : tsym = target->symtree->n.sym;
5452 458 : if (!tsym->result)
5453 0 : tsym->result = tsym;
5454 458 : sym->ts = tsym->result->ts;
5455 458 : 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 440 : target->rank = tsym->result->as ? tsym->result->as->rank : 0;
5467 440 : 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 1828 : if (!sym->assoc->inferred_type && target->ref && gfc_resolve_ref (target)
5476 654 : && target->expr_type != EXPR_ARRAY
5477 2500 : && target->expr_type != EXPR_COMPCALL)
5478 653 : 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 1846 : if (target->expr_type == EXPR_FUNCTION && target->ts.type == BT_UNKNOWN)
5484 : {
5485 420 : gfc_symbol *derived;
5486 : /* The derived type has a leading uppercase character. */
5487 420 : gfc_find_symbol (gfc_dt_upper_string (target->symtree->name),
5488 420 : gfc_current_ns->parent, 1, &derived);
5489 420 : 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 1846 : rank = target->rank;
5498 1846 : corank = target->corank;
5499 : /* Fixup cases where the ranks are mismatched. */
5500 1846 : 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 1682 : 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 1668 : else if ((!sym->as && (rank != 0 || corank != 0))
5560 1126 : || (sym->as
5561 0 : && (sym->as->rank != rank || sym->as->corank != corank)))
5562 : {
5563 542 : as = gfc_get_array_spec ();
5564 542 : as->type = AS_DEFERRED;
5565 542 : as->rank = rank;
5566 542 : as->corank = corank;
5567 542 : sym->as = as;
5568 542 : if (rank)
5569 526 : sym->attr.dimension = 1;
5570 542 : if (corank)
5571 : {
5572 18 : as->cotype = AS_ASSUMED_SHAPE;
5573 18 : sym->attr.codimension = 1;
5574 : }
5575 : }
5576 1846 : gfc_commit_symbols ();
5577 : }
5578 1686 : }
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 1683 : parse_associate (void)
5585 : {
5586 1683 : gfc_namespace* my_ns;
5587 1683 : gfc_state_data s;
5588 1683 : gfc_statement st;
5589 :
5590 1683 : gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
5591 :
5592 1683 : my_ns = gfc_build_block_ns (gfc_current_ns);
5593 :
5594 1683 : new_st.op = EXEC_BLOCK;
5595 1683 : new_st.ext.block.ns = my_ns;
5596 1683 : 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 1683 : gfc_current_ns = my_ns;
5601 1683 : move_associates_to_block ();
5602 :
5603 1683 : accept_statement (ST_ASSOCIATE);
5604 1683 : push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
5605 :
5606 1685 : loop:
5607 1685 : st = parse_executable (ST_NONE);
5608 1682 : switch (st)
5609 : {
5610 0 : case ST_NONE:
5611 0 : unexpected_eof ();
5612 :
5613 1680 : case_end:
5614 1680 : accept_statement (st);
5615 1680 : my_ns->code = gfc_state_stack->head;
5616 1680 : break;
5617 :
5618 2 : default:
5619 2 : unexpected_statement (st);
5620 2 : goto loop;
5621 : }
5622 :
5623 1680 : gfc_current_ns = gfc_current_ns->parent;
5624 1680 : pop_state ();
5625 1680 : }
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 17960 : get_current_team_context (void)
5637 : {
5638 18032 : return team_context_stack.is_empty () ? NULL : team_context_stack.last ();
5639 : }
5640 :
5641 :
5642 : static void
5643 131 : parse_change_team (void)
5644 : {
5645 131 : gfc_namespace *my_ns;
5646 131 : gfc_state_data s;
5647 131 : gfc_statement st;
5648 131 : vec<gfc_expr *> *team_allocs;
5649 :
5650 131 : gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM construct at %C");
5651 :
5652 131 : my_ns = gfc_build_block_ns (gfc_current_ns);
5653 :
5654 131 : new_st.op = EXEC_CHANGE_TEAM;
5655 131 : 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 131 : gfc_current_ns = my_ns;
5660 131 : if (new_st.ext.block.assoc)
5661 3 : move_associates_to_block ();
5662 :
5663 131 : accept_statement (ST_CHANGE_TEAM);
5664 131 : push_state (&s, COMP_CHANGE_TEAM, my_ns->proc_name);
5665 :
5666 : /* Push team context for tracking coarrays allocated in a team block. */
5667 131 : team_context_stack.safe_push (gfc_current_ns);
5668 :
5669 131 : loop:
5670 131 : st = parse_executable (ST_NONE);
5671 131 : switch (st)
5672 : {
5673 0 : case ST_NONE:
5674 0 : unexpected_eof ();
5675 :
5676 131 : case_end:
5677 131 : accept_statement (st);
5678 131 : my_ns->code = gfc_state_stack->head;
5679 : /* F2018(11.1.5.2): Deallocate coarray expressions allocated in this
5680 : team block, */
5681 131 : team_allocs = team_allocated_coarrays.get (gfc_current_ns);
5682 131 : if (team_allocs)
5683 28 : deallocate_allocated_coarrays (team_allocs);
5684 : /* Pop team context. */
5685 131 : team_context_stack.pop ();
5686 131 : break;
5687 :
5688 0 : default:
5689 0 : unexpected_statement (st);
5690 0 : goto loop;
5691 : }
5692 :
5693 131 : gfc_current_ns = gfc_current_ns->parent;
5694 131 : pop_state ();
5695 131 : }
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 33447 : parse_do_block (void)
5703 : {
5704 33447 : gfc_statement st;
5705 33447 : gfc_code *top;
5706 33447 : gfc_state_data s;
5707 33447 : gfc_symtree *stree;
5708 33447 : gfc_exec_op do_op;
5709 :
5710 33447 : do_op = new_st.op;
5711 33447 : s.ext.end_do_label = new_st.label1;
5712 :
5713 33447 : if (do_op == EXEC_DO_CONCURRENT)
5714 : {
5715 352 : gfc_forall_iterator *fa;
5716 723 : 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 371 : if (directive_unroll != -1)
5721 : {
5722 1 : fa->annot.unroll = directive_unroll;
5723 1 : directive_unroll = -1;
5724 : }
5725 371 : if (directive_ivdep)
5726 1 : fa->annot.ivdep = directive_ivdep;
5727 371 : if (directive_vector)
5728 1 : fa->annot.vector = directive_vector;
5729 371 : if (directive_novector)
5730 2 : fa->annot.novector = directive_novector;
5731 : }
5732 352 : directive_ivdep = false;
5733 352 : directive_vector = false;
5734 352 : directive_novector = false;
5735 352 : stree = NULL;
5736 : }
5737 33095 : else if (new_st.ext.iterator != NULL)
5738 : {
5739 32542 : stree = new_st.ext.iterator->var->symtree;
5740 32542 : if (directive_unroll != -1)
5741 : {
5742 16 : new_st.ext.iterator->annot.unroll = directive_unroll;
5743 16 : directive_unroll = -1;
5744 : }
5745 32542 : if (directive_ivdep)
5746 : {
5747 2 : new_st.ext.iterator->annot.ivdep = directive_ivdep;
5748 2 : directive_ivdep = false;
5749 : }
5750 32542 : if (directive_vector)
5751 : {
5752 2 : new_st.ext.iterator->annot.vector = directive_vector;
5753 2 : directive_vector = false;
5754 : }
5755 32542 : 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 33447 : accept_statement (ST_DO);
5765 :
5766 33447 : top = gfc_state_stack->tail;
5767 66542 : push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
5768 : gfc_new_block);
5769 :
5770 33447 : s.do_variable = stree;
5771 :
5772 33447 : top->block = new_level (top);
5773 33447 : top->block->op = EXEC_DO;
5774 :
5775 33448 : loop:
5776 33448 : st = parse_executable (ST_NONE);
5777 :
5778 33446 : switch (st)
5779 : {
5780 0 : case ST_NONE:
5781 0 : unexpected_eof ();
5782 :
5783 31272 : case ST_ENDDO:
5784 31272 : 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 31272 : 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 33445 : pop_state ();
5813 33445 : accept_statement (st);
5814 33445 : }
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 14183 : gfc_omp_end_stmt (gfc_statement omp_st,
5821 : bool omp_do_p, bool omp_structured_p)
5822 : {
5823 14183 : if (omp_do_p)
5824 : {
5825 5339 : switch (omp_st)
5826 : {
5827 : case ST_OMP_DISTRIBUTE: return ST_OMP_END_DISTRIBUTE;
5828 46 : case ST_OMP_DISTRIBUTE_PARALLEL_DO:
5829 46 : 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 1246 : case ST_OMP_DO: return ST_OMP_END_DO;
5835 136 : 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 794 : 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 14 : case ST_OMP_PARALLEL_MASTER_TASKLOOP:
5873 14 : 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 416 : case ST_OMP_UNROLL:
5889 416 : return ST_OMP_END_UNROLL;
5890 : default:
5891 : break;
5892 : }
5893 : }
5894 :
5895 8897 : if (omp_structured_p)
5896 : {
5897 8897 : 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 5279 : parse_omp_do (gfc_statement omp_st, int nested)
5965 : {
5966 5279 : gfc_statement st;
5967 5279 : gfc_code *cp, *np;
5968 5279 : gfc_state_data s;
5969 :
5970 5279 : accept_statement (omp_st);
5971 :
5972 5279 : cp = gfc_state_stack->tail;
5973 5279 : push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5974 5279 : np = new_level (cp);
5975 5279 : np->op = cp->op;
5976 5279 : np->block = NULL;
5977 :
5978 5365 : for (;;)
5979 : {
5980 5322 : st = next_statement ();
5981 5322 : if (st == ST_NONE)
5982 2 : unexpected_eof ();
5983 5320 : 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 4934 : parse_do_block ();
5997 10211 : for (; nested; --nested)
5998 343 : pop_state ();
5999 4934 : 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 4932 : check_do_closure ();
6016 4932 : pop_state ();
6017 :
6018 4932 : st = next_statement ();
6019 5275 : do_end:
6020 5275 : gfc_statement omp_end_st = gfc_omp_end_stmt (omp_st, true, false);
6021 5275 : 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 5275 : 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 5275 : 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 2707 : parse_omp_oacc_atomic (bool omp_p)
6066 : {
6067 2707 : gfc_statement st, st_atomic, st_end_atomic;
6068 2707 : gfc_code *cp, *np;
6069 2707 : gfc_state_data s;
6070 2707 : int count;
6071 :
6072 2707 : if (omp_p)
6073 : {
6074 2164 : st_atomic = ST_OMP_ATOMIC;
6075 2164 : if (gfc_state_stack->state == COMP_OMP_BEGIN_METADIRECTIVE)
6076 : st_end_atomic = ST_OMP_END_METADIRECTIVE;
6077 : else
6078 2162 : 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 2707 : accept_statement (st_atomic);
6086 :
6087 2707 : cp = gfc_state_stack->tail;
6088 2707 : push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
6089 2707 : np = new_level (cp);
6090 2707 : np->op = cp->op;
6091 2707 : np->block = NULL;
6092 2707 : np->ext.omp_clauses = cp->ext.omp_clauses;
6093 2707 : cp->ext.omp_clauses = NULL;
6094 2707 : count = 1 + np->ext.omp_clauses->capture;
6095 :
6096 5939 : while (count)
6097 : {
6098 3232 : st = next_statement ();
6099 3232 : if (st == ST_NONE)
6100 0 : unexpected_eof ();
6101 3232 : else if (np->ext.omp_clauses->compare
6102 195 : && (st == ST_SIMPLE_IF || st == ST_IF_BLOCK))
6103 : {
6104 157 : count--;
6105 157 : 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 157 : accept_statement (st);
6113 : }
6114 3075 : else if (st == ST_ASSIGNMENT
6115 3074 : && (!np->ext.omp_clauses->compare
6116 38 : || np->ext.omp_clauses->capture))
6117 : {
6118 3074 : accept_statement (st);
6119 3074 : count--;
6120 : }
6121 : else
6122 1 : unexpected_statement (st);
6123 : }
6124 :
6125 2707 : pop_state ();
6126 :
6127 2707 : st = next_statement ();
6128 2707 : if (st == st_end_atomic)
6129 : {
6130 728 : gfc_clear_new_st ();
6131 728 : gfc_commit_symbols ();
6132 728 : gfc_warning_check ();
6133 728 : st = next_statement ();
6134 : }
6135 2707 : 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 8844 : parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
6345 : {
6346 8844 : gfc_statement st, omp_end_st, first_st;
6347 8844 : gfc_code *cp, *np;
6348 8844 : gfc_state_data s, s2;
6349 :
6350 8844 : accept_statement (omp_st);
6351 :
6352 8844 : cp = gfc_state_stack->tail;
6353 8844 : push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
6354 8844 : np = new_level (cp);
6355 8844 : np->op = cp->op;
6356 8844 : np->block = NULL;
6357 :
6358 8844 : omp_end_st = gfc_omp_end_stmt (omp_st, false, true);
6359 8844 : 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 8844 : if (gfc_state_stack->previous != NULL
6365 8844 : && gfc_state_stack->previous->state == COMP_OMP_BEGIN_METADIRECTIVE)
6366 8844 : omp_end_st = ST_OMP_END_METADIRECTIVE;
6367 :
6368 8844 : bool block_construct = false;
6369 8844 : gfc_namespace *my_ns = NULL;
6370 8844 : gfc_namespace *my_parent = NULL;
6371 :
6372 8844 : first_st = st = next_statement ();
6373 :
6374 8844 : 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 408 : s.state = COMP_OMP_STRICTLY_STRUCTURED_BLOCK;
6379 :
6380 408 : block_construct = true;
6381 408 : gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
6382 :
6383 408 : my_ns = gfc_build_block_ns (gfc_current_ns);
6384 408 : new_st.op = EXEC_BLOCK;
6385 408 : new_st.ext.block.ns = my_ns;
6386 408 : new_st.ext.block.assoc = NULL;
6387 408 : accept_statement (ST_BLOCK);
6388 :
6389 408 : push_state (&s2, COMP_BLOCK, my_ns->proc_name);
6390 408 : gfc_current_ns = my_ns;
6391 408 : my_parent = my_ns->parent;
6392 408 : if (omp_st == ST_OMP_SECTIONS
6393 408 : || omp_st == ST_OMP_PARALLEL_SECTIONS)
6394 : {
6395 2 : np = new_level (cp);
6396 2 : np->op = cp->op;
6397 : }
6398 :
6399 408 : first_st = next_statement ();
6400 408 : st = parse_spec (first_st);
6401 : }
6402 :
6403 8844 : if (omp_end_st == ST_OMP_END_TARGET)
6404 2190 : switch (first_st)
6405 : {
6406 193 : case ST_OMP_TEAMS:
6407 193 : case ST_OMP_TEAMS_DISTRIBUTE:
6408 193 : case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
6409 193 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
6410 193 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6411 193 : case ST_OMP_TEAMS_LOOP:
6412 193 : case ST_OMP_METADIRECTIVE:
6413 193 : case ST_OMP_BEGIN_METADIRECTIVE:
6414 193 : {
6415 193 : gfc_state_data *stk = gfc_state_stack->previous;
6416 193 : if (stk->state == COMP_OMP_STRICTLY_STRUCTURED_BLOCK)
6417 20 : stk = stk->previous;
6418 193 : stk->tail->ext.omp_clauses->target_first_st_is_teams_or_meta = true;
6419 193 : break;
6420 : }
6421 : default:
6422 : break;
6423 : }
6424 :
6425 9084 : do
6426 : {
6427 9084 : 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 8975 : st = parse_executable (st);
6502 9068 : if (st == ST_NONE)
6503 0 : unexpected_eof ();
6504 9068 : 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 8811 : else if (block_construct && st == ST_END_BLOCK)
6514 : {
6515 408 : accept_statement (st);
6516 408 : gfc_current_ns->code = gfc_state_stack->head;
6517 408 : gfc_current_ns = my_parent;
6518 408 : pop_state (); /* Inner BLOCK */
6519 408 : pop_state (); /* Outer COMP_OMP_STRICTLY_STRUCTURED_BLOCK */
6520 :
6521 408 : st = next_statement ();
6522 408 : if (st == omp_end_st)
6523 : {
6524 112 : accept_statement (st);
6525 112 : st = next_statement ();
6526 : }
6527 296 : 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 8403 : else if (st != omp_end_st || block_construct)
6538 : {
6539 4 : unexpected_statement (st);
6540 4 : st = next_statement ();
6541 : }
6542 : }
6543 8660 : while (st != omp_end_st);
6544 :
6545 8420 : switch (new_st.op)
6546 : {
6547 2273 : case EXEC_OMP_END_NOWAIT:
6548 2273 : 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 2273 : cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
6553 2273 : break;
6554 156 : case EXEC_OMP_END_CRITICAL:
6555 156 : if (((cp->ext.omp_clauses->critical_name == NULL)
6556 156 : ^ (new_st.ext.omp_name == NULL))
6557 156 : || (new_st.ext.omp_name != NULL
6558 48 : && 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 156 : free (const_cast<char *> (new_st.ext.omp_name));
6563 156 : new_st.ext.omp_name = NULL;
6564 156 : break;
6565 551 : case EXEC_OMP_END_SINGLE:
6566 551 : 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 551 : cp->ext.omp_clauses->nowait |= new_st.ext.omp_clauses->nowait;
6571 551 : 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 546 : cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
6581 546 : = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
6582 551 : new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
6583 551 : gfc_free_omp_clauses (new_st.ext.omp_clauses);
6584 551 : break;
6585 : case EXEC_NOP:
6586 : break;
6587 0 : default:
6588 0 : gcc_unreachable ();
6589 : }
6590 :
6591 8420 : gfc_clear_new_st ();
6592 8420 : gfc_commit_symbols ();
6593 8420 : gfc_warning_check ();
6594 8420 : pop_state ();
6595 8420 : st = next_statement ();
6596 8420 : 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 128 : parse_omp_metadirective_body (gfc_statement omp_st)
6646 : {
6647 128 : gfc_omp_variant *variant
6648 : = new_st.ext.omp_variants;
6649 128 : locus body_locus = gfc_current_locus;
6650 128 : bool saw_error = false;
6651 :
6652 128 : accept_statement (omp_st);
6653 :
6654 128 : gfc_statement next_st = ST_NONE;
6655 128 : locus next_loc;
6656 :
6657 531 : while (variant)
6658 : {
6659 276 : gfc_current_locus = body_locus;
6660 276 : gfc_state_data s;
6661 276 : bool workshare_p
6662 276 : = (variant->stmt == ST_OMP_WORKSHARE
6663 276 : || variant->stmt == ST_OMP_PARALLEL_WORKSHARE);
6664 70 : enum gfc_compile_state new_state
6665 : = (omp_st == ST_OMP_METADIRECTIVE
6666 276 : ? COMP_OMP_METADIRECTIVE : COMP_OMP_BEGIN_METADIRECTIVE);
6667 :
6668 276 : new_st = *variant->code;
6669 276 : push_state (&s, new_state, NULL);
6670 :
6671 276 : gfc_statement st;
6672 276 : bool old_in_metadirective_body = gfc_in_omp_metadirective_body;
6673 276 : gfc_in_omp_metadirective_body = true;
6674 :
6675 276 : gfc_omp_metadirective_region_count++;
6676 276 : gfc_omp_metadirective_region_stack.safe_push (
6677 : gfc_omp_metadirective_region_count);
6678 :
6679 276 : switch (variant->stmt)
6680 : {
6681 37 : case_omp_structured_block:
6682 37 : st = parse_omp_structured_block (variant->stmt, workshare_p);
6683 37 : 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 91 : default:
6698 91 : accept_statement (variant->stmt);
6699 91 : st = parse_executable (next_statement ());
6700 91 : break;
6701 : }
6702 :
6703 275 : if (gfc_state_stack->state == COMP_OMP_METADIRECTIVE
6704 275 : && 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 275 : finish:
6718 :
6719 : /* Sanity-check that each variant finishes parsing at the same place. */
6720 275 : if (next_st == ST_NONE)
6721 : {
6722 127 : next_st = st;
6723 127 : next_loc = gfc_current_locus;
6724 : }
6725 148 : else if (st != next_st
6726 143 : || next_loc.nextc != gfc_current_locus.nextc
6727 142 : || 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 275 : gfc_in_omp_metadirective_body = old_in_metadirective_body;
6735 :
6736 275 : if (gfc_state_stack->head)
6737 272 : *variant->code = *gfc_state_stack->head;
6738 275 : pop_state ();
6739 :
6740 275 : gfc_omp_metadirective_region_stack.pop ();
6741 275 : int outer_omp_metadirective_region
6742 275 : = 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 275 : if (gfc_statement_label)
6747 18 : gfc_statement_label = gfc_rebind_label (gfc_statement_label,
6748 : outer_omp_metadirective_region);
6749 275 : 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 275 : if (new_st.label1)
6756 4 : new_st.label1
6757 4 : = gfc_rebind_label (new_st.label1, outer_omp_metadirective_region);
6758 275 : if (new_st.here)
6759 18 : new_st.here
6760 18 : = gfc_rebind_label (new_st.here, outer_omp_metadirective_region);
6761 :
6762 275 : gfc_commit_symbols ();
6763 275 : gfc_warning_check ();
6764 275 : if (variant->next)
6765 148 : gfc_clear_new_st ();
6766 :
6767 275 : variant = variant->next;
6768 : }
6769 :
6770 127 : 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 127 : 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 155019 : parse_executable (gfc_statement st)
6793 : {
6794 155019 : int close_flag;
6795 155019 : bool one_stmt_p = false;
6796 155019 : in_exec_part = true;
6797 :
6798 155019 : if (st == ST_NONE)
6799 71047 : st = next_statement ();
6800 :
6801 910996 : for (;;)
6802 : {
6803 : /* Only parse one statement for the form of metadirective without
6804 : an explicit begin..end. */
6805 910996 : if (gfc_state_stack->state == COMP_OMP_METADIRECTIVE && one_stmt_p)
6806 : return st;
6807 910940 : one_stmt_p = true;
6808 :
6809 910940 : close_flag = check_do_closure ();
6810 910940 : 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 910940 : 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 684700 : case ST_FORMAT:
6848 684700 : case ST_ENTRY:
6849 684700 : case_executable:
6850 684700 : accept_statement (st);
6851 684700 : if (close_flag == 1)
6852 : return ST_IMPLIED_ENDDO;
6853 : break;
6854 :
6855 1121 : case ST_BLOCK:
6856 1121 : parse_block_construct ();
6857 1121 : break;
6858 :
6859 1683 : case ST_ASSOCIATE:
6860 1683 : parse_associate ();
6861 1683 : break;
6862 :
6863 131 : case ST_CHANGE_TEAM:
6864 131 : parse_change_team ();
6865 131 : break;
6866 :
6867 15001 : case ST_IF_BLOCK:
6868 15001 : parse_if_block ();
6869 15001 : break;
6870 :
6871 550 : case ST_SELECT_CASE:
6872 550 : parse_select_block ();
6873 550 : break;
6874 :
6875 3221 : case ST_SELECT_TYPE:
6876 3221 : parse_select_type_block ();
6877 3221 : break;
6878 :
6879 1048 : case ST_SELECT_RANK:
6880 1048 : parse_select_rank_block ();
6881 1048 : break;
6882 :
6883 23241 : case ST_DO:
6884 23241 : parse_do_block ();
6885 23239 : 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 8780 : case_omp_structured_block:
6924 17546 : st = parse_omp_structured_block (st,
6925 8780 : st == ST_OMP_WORKSHARE
6926 8780 : || st == ST_OMP_PARALLEL_WORKSHARE);
6927 8766 : continue;
6928 :
6929 4790 : case_omp_do:
6930 4790 : st = parse_omp_do (st, 0);
6931 4788 : if (st == ST_IMPLIED_ENDDO)
6932 : return st;
6933 4786 : continue;
6934 :
6935 543 : case ST_OACC_ATOMIC:
6936 543 : st = parse_omp_oacc_atomic (false);
6937 543 : continue;
6938 :
6939 2152 : case ST_OMP_ATOMIC:
6940 2152 : st = parse_omp_oacc_atomic (true);
6941 2152 : continue;
6942 :
6943 153 : case ST_OMP_DISPATCH:
6944 153 : st = parse_omp_dispatch ();
6945 153 : continue;
6946 :
6947 128 : case ST_OMP_METADIRECTIVE:
6948 128 : case ST_OMP_BEGIN_METADIRECTIVE:
6949 128 : st = parse_omp_metadirective_body (st);
6950 127 : continue;
6951 :
6952 62 : case ST_OMP_END_METADIRECTIVE:
6953 62 : if (gfc_state_stack->state == COMP_OMP_BEGIN_METADIRECTIVE)
6954 30 : return next_statement ();
6955 : else
6956 : return st;
6957 :
6958 : default:
6959 : return st;
6960 : }
6961 :
6962 734105 : if (directive_unroll != -1)
6963 1 : gfc_error ("%<GCC unroll%> directive not at the start of a loop at %C");
6964 :
6965 734105 : if (directive_ivdep)
6966 0 : gfc_error ("%<GCC ivdep%> directive not at the start of a loop at %C");
6967 :
6968 734105 : if (directive_vector)
6969 0 : gfc_error ("%<GCC vector%> directive not at the start of a loop at %C");
6970 :
6971 734105 : if (directive_novector)
6972 0 : gfc_error ("%<GCC novector%> "
6973 : "directive not at the start of a loop at %C");
6974 :
6975 734105 : 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 80786 : fixup_st_func_formals (gfc_symtree *st, gfc_symbol *old_sym,
6987 : gfc_symbol *new_sym)
6988 : {
6989 80786 : if (st == NULL)
6990 : return;
6991 :
6992 38656 : fixup_st_func_formals (st->left, old_sym, new_sym);
6993 38656 : fixup_st_func_formals (st->right, old_sym, new_sym);
6994 :
6995 38656 : 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 206762 : gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
7007 : {
7008 206762 : gfc_namespace *ns;
7009 206762 : gfc_symtree *st;
7010 206762 : gfc_symbol *old_sym;
7011 206762 : bool imported;
7012 :
7013 375189 : for (ns = siblings; ns; ns = ns->sibling)
7014 : {
7015 168427 : st = gfc_find_symtree (ns->sym_root, sym->name);
7016 :
7017 168427 : if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
7018 126636 : goto fixup_contained;
7019 :
7020 41791 : if ((st->n.sym->attr.flavor == FL_DERIVED
7021 0 : && sym->attr.generic && sym->attr.function)
7022 41791 : ||(sym->attr.flavor == FL_DERIVED
7023 0 : && st->n.sym->attr.generic && st->n.sym->attr.function))
7024 0 : goto fixup_contained;
7025 :
7026 41791 : old_sym = st->n.sym;
7027 41791 : imported = old_sym->attr.imported == 1;
7028 41791 : if (old_sym->ns == ns
7029 3698 : && !old_sym->attr.contained
7030 :
7031 : /* By 14.6.1.3, host association should be excluded
7032 : for the following. */
7033 3683 : && !(old_sym->attr.external
7034 3683 : || (old_sym->ts.type != BT_UNKNOWN
7035 193 : && !old_sym->attr.implicit_type)
7036 3491 : || old_sym->attr.flavor == FL_PARAMETER
7037 3491 : || old_sym->attr.use_assoc
7038 3484 : || old_sym->attr.in_common
7039 3484 : || old_sym->attr.in_equivalence
7040 3484 : || old_sym->attr.data
7041 3484 : || old_sym->attr.dummy
7042 3484 : || old_sym->attr.result
7043 3484 : || old_sym->attr.dimension
7044 3484 : || old_sym->attr.allocatable
7045 3484 : || old_sym->attr.intrinsic
7046 3484 : || old_sym->attr.generic
7047 3476 : || old_sym->attr.flavor == FL_NAMELIST
7048 3475 : || old_sym->attr.flavor == FL_LABEL
7049 3474 : || old_sym->attr.proc == PROC_ST_FUNCTION))
7050 : {
7051 : /* Replace it with the symbol from the parent namespace. */
7052 3474 : st->n.sym = sym;
7053 3474 : sym->refs++;
7054 3474 : 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 3474 : fixup_st_func_formals (ns->sym_root, old_sym, sym);
7060 :
7061 3474 : gfc_release_symbol (old_sym);
7062 : }
7063 :
7064 38317 : fixup_contained:
7065 : /* Do the same for any contained procedures. */
7066 168427 : gfc_fixup_sibling_symbols (sym, ns->contained);
7067 : }
7068 206762 : }
7069 :
7070 : static void
7071 15672 : parse_contained (int module)
7072 : {
7073 15672 : gfc_namespace *ns, *parent_ns, *tmp;
7074 15672 : gfc_state_data s1, s2;
7075 15672 : gfc_statement st;
7076 15672 : gfc_symbol *sym;
7077 15672 : gfc_entry_list *el;
7078 15672 : locus old_loc;
7079 15672 : int contains_statements = 0;
7080 15672 : int seen_error = 0;
7081 :
7082 15672 : push_state (&s1, COMP_CONTAINS, NULL);
7083 15672 : parent_ns = gfc_current_ns;
7084 :
7085 53751 : do
7086 : {
7087 53751 : gfc_current_ns = gfc_get_namespace (parent_ns, 1);
7088 :
7089 53751 : gfc_current_ns->sibling = parent_ns->contained;
7090 53751 : parent_ns->contained = gfc_current_ns;
7091 :
7092 53776 : next:
7093 : /* Process the next available statement. We come here if we got an error
7094 : and rejected the last statement. */
7095 53776 : old_loc = gfc_current_locus;
7096 53776 : st = next_statement ();
7097 :
7098 53776 : switch (st)
7099 : {
7100 1 : case ST_NONE:
7101 1 : unexpected_eof ();
7102 :
7103 38081 : case ST_FUNCTION:
7104 38081 : case ST_SUBROUTINE:
7105 38081 : contains_statements = 1;
7106 38081 : accept_statement (st);
7107 :
7108 65246 : 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 38081 : if (!module)
7116 : {
7117 20085 : 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 20085 : if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
7123 : sym->name,
7124 20085 : &gfc_new_block->declared_at))
7125 : {
7126 20084 : if (st == ST_FUNCTION)
7127 4688 : gfc_add_function (&sym->attr, sym->name,
7128 4688 : &gfc_new_block->declared_at);
7129 : else
7130 15396 : gfc_add_subroutine (&sym->attr, sym->name,
7131 15396 : &gfc_new_block->declared_at);
7132 : }
7133 : }
7134 :
7135 20085 : gfc_commit_symbols ();
7136 : }
7137 : else
7138 17996 : sym = gfc_new_block;
7139 :
7140 : /* Mark this as a contained function, so it isn't replaced
7141 : by other module functions. */
7142 38081 : 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 38081 : if (!sym->attr.pure)
7148 35553 : sym->attr.implicit_pure = 1;
7149 :
7150 38081 : parse_progunit (ST_NONE);
7151 :
7152 : /* Fix up any sibling functions that refer to this one. */
7153 38079 : gfc_fixup_sibling_symbols (sym, gfc_current_ns);
7154 : /* Or refer to any of its alternate entry points. */
7155 38335 : for (el = gfc_current_ns->entries; el; el = el->next)
7156 256 : gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
7157 :
7158 38079 : gfc_current_ns->code = s2.head;
7159 38079 : gfc_current_ns = parent_ns;
7160 :
7161 38079 : pop_state ();
7162 38079 : break;
7163 :
7164 : /* These statements are associated with the end of the host unit. */
7165 15669 : case ST_END_FUNCTION:
7166 15669 : case ST_END_MODULE:
7167 15669 : case ST_END_SUBMODULE:
7168 15669 : case ST_END_PROGRAM:
7169 15669 : case ST_END_SUBROUTINE:
7170 15669 : accept_statement (st);
7171 15669 : gfc_current_ns->code = s1.head;
7172 15669 : 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 53748 : break;
7181 : }
7182 : }
7183 53748 : while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
7184 52836 : && st != ST_END_MODULE && st != ST_END_SUBMODULE
7185 98902 : && st != ST_END_PROGRAM);
7186 :
7187 : /* The first namespace in the list is guaranteed to not have
7188 : anything (worthwhile) in it. */
7189 15669 : tmp = gfc_current_ns;
7190 15669 : gfc_current_ns = parent_ns;
7191 15669 : if (seen_error && tmp->refs > 1)
7192 0 : gfc_free_namespace (tmp);
7193 :
7194 15669 : ns = gfc_current_ns->contained;
7195 15669 : gfc_current_ns->contained = ns->sibling;
7196 15669 : gfc_free_namespace (ns);
7197 :
7198 15669 : pop_state ();
7199 15669 : if (!contains_statements)
7200 68 : gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without "
7201 : "FUNCTION or SUBROUTINE statement at %L", &old_loc);
7202 15669 : }
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 79607 : parse_progunit (gfc_statement st)
7238 : {
7239 79607 : gfc_state_data *p;
7240 79607 : int n;
7241 :
7242 79607 : gfc_adjust_builtins ();
7243 :
7244 79607 : if (gfc_new_block
7245 70711 : && gfc_new_block->abr_modproc_decl
7246 264 : && gfc_new_block->attr.function)
7247 116 : get_modproc_result ();
7248 :
7249 79607 : st = parse_spec (st);
7250 79588 : 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 4729 : case_end:
7262 4729 : accept_statement (st);
7263 4729 : goto done;
7264 :
7265 : default:
7266 : break;
7267 : }
7268 :
7269 74666 : if (gfc_current_state () == COMP_FUNCTION)
7270 13286 : gfc_check_function_type (gfc_current_ns);
7271 :
7272 74666 : loop:
7273 74909 : for (;;)
7274 : {
7275 74909 : st = parse_executable (st);
7276 :
7277 74883 : switch (st)
7278 : {
7279 0 : case ST_NONE:
7280 0 : unexpected_eof ();
7281 :
7282 7798 : case ST_CONTAINS:
7283 : /* This is not allowed within BLOCK! */
7284 7798 : if (gfc_current_state () != COMP_BLOCK)
7285 7796 : goto contains;
7286 : break;
7287 :
7288 66844 : case_end:
7289 66844 : accept_statement (st);
7290 66844 : 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 7989 : contains:
7311 7989 : n = 0;
7312 :
7313 24587 : for (p = gfc_state_stack; p; p = p->previous)
7314 16598 : if (p->state == COMP_CONTAINS)
7315 310 : n++;
7316 :
7317 7989 : if (gfc_find_state (COMP_MODULE) == true
7318 7989 : || gfc_find_state (COMP_SUBMODULE) == true)
7319 310 : n--;
7320 :
7321 7989 : 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 7989 : parse_contained (0);
7331 :
7332 79560 : done:
7333 79560 : gfc_current_ns->code = gfc_state_stack->head;
7334 79560 : }
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 10449 : parse_module (void)
7498 : {
7499 10449 : gfc_statement st;
7500 10449 : gfc_gsymbol *s;
7501 :
7502 10449 : s = gfc_get_gsymbol (gfc_new_block->name, false);
7503 10449 : 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 10448 : s->type = GSYM_MODULE;
7508 10448 : s->where = gfc_new_block->declared_at;
7509 10448 : 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 10449 : 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 10448 : st = parse_spec (ST_NONE);
7548 :
7549 10450 : loop:
7550 10450 : switch (st)
7551 : {
7552 0 : case ST_NONE:
7553 0 : unexpected_eof ();
7554 :
7555 7683 : case ST_CONTAINS:
7556 7683 : parse_contained (1);
7557 7683 : break;
7558 :
7559 2764 : case ST_END_MODULE:
7560 2764 : case ST_END_SUBMODULE:
7561 2764 : accept_statement (st);
7562 2764 : 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 10446 : s->ns = gfc_current_ns;
7572 10446 : }
7573 :
7574 :
7575 : /* Add a procedure name to the global symbol table. */
7576 :
7577 : static void
7578 11809 : add_global_procedure (bool sub)
7579 : {
7580 11809 : 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 11809 : if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008))
7585 : {
7586 11403 : s = gfc_get_gsymbol (gfc_new_block->name, false);
7587 :
7588 11403 : if (s->defined
7589 11401 : || (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 11401 : s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
7599 11401 : s->sym_name = gfc_new_block->name;
7600 11401 : s->where = gfc_new_block->declared_at;
7601 11401 : s->defined = 1;
7602 11401 : s->ns = gfc_current_ns;
7603 : }
7604 : }
7605 :
7606 : /* Don't add the symbol multiple times. */
7607 11809 : if (gfc_new_block->binding_label
7608 11809 : && (!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 11809 : }
7632 :
7633 :
7634 : /* Add a program to the global symbol table. */
7635 :
7636 : static void
7637 19886 : add_global_program (void)
7638 : {
7639 19886 : gfc_gsymbol *s;
7640 :
7641 19886 : if (gfc_new_block == NULL)
7642 : return;
7643 19886 : s = gfc_get_gsymbol (gfc_new_block->name, false);
7644 :
7645 19886 : 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 19886 : s->type = GSYM_PROGRAM;
7650 19886 : s->where = gfc_new_block->declared_at;
7651 19886 : s->defined = 1;
7652 19886 : 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 531 : rewrite_expr_tree (gfc_namespace *gfc_global_ns_list)
7661 : {
7662 1120 : for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
7663 589 : gfc_current_ns = gfc_current_ns->sibling)
7664 589 : gfc_coarray_rewrite (gfc_current_ns);
7665 531 : }
7666 :
7667 : /* Resolve all the program units. */
7668 : static void
7669 32492 : resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
7670 : {
7671 32492 : gfc_derived_types = NULL;
7672 32492 : gfc_current_ns = gfc_global_ns_list;
7673 80588 : for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
7674 : {
7675 48097 : if (gfc_current_ns->proc_name
7676 48097 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
7677 10436 : continue; /* Already resolved. */
7678 :
7679 37661 : if (gfc_current_ns->proc_name)
7680 37661 : gfc_current_locus = gfc_current_ns->proc_name->declared_at;
7681 37661 : gfc_resolve (gfc_current_ns);
7682 37660 : gfc_current_ns->derived_types = gfc_derived_types;
7683 37660 : gfc_derived_types = NULL;
7684 : }
7685 32491 : }
7686 :
7687 :
7688 : static void
7689 225389 : clean_up_modules (gfc_gsymbol *&gsym)
7690 : {
7691 225389 : if (gsym == NULL)
7692 : return;
7693 :
7694 96449 : clean_up_modules (gsym->left);
7695 96449 : clean_up_modules (gsym->right);
7696 :
7697 96449 : if (gsym->type != GSYM_MODULE)
7698 : return;
7699 :
7700 10825 : if (gsym->ns)
7701 : {
7702 10825 : 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 10825 : gfc_current_ns->parent = NULL;
7708 10825 : gfc_derived_types = gfc_current_ns->derived_types;
7709 10825 : gfc_done_2 ();
7710 10825 : gsym->ns = NULL;
7711 : }
7712 10825 : free (gsym);
7713 10825 : 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 32491 : translate_all_program_units (gfc_namespace *gfc_global_ns_list)
7721 : {
7722 32491 : int errors;
7723 :
7724 32491 : gfc_current_ns = gfc_global_ns_list;
7725 32491 : 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 111872 : for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
7731 : {
7732 46890 : if (!gfc_current_ns->proc_name
7733 46890 : || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
7734 37298 : continue;
7735 :
7736 9592 : gfc_current_locus = gfc_current_ns->proc_name->declared_at;
7737 9592 : gfc_derived_types = gfc_current_ns->derived_types;
7738 9592 : gfc_generate_module_code (gfc_current_ns);
7739 9592 : gfc_current_ns->translated = 1;
7740 : }
7741 :
7742 32491 : gfc_current_ns = gfc_global_ns_list;
7743 79381 : for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
7744 : {
7745 46890 : if (gfc_current_ns->proc_name
7746 46890 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
7747 9592 : continue;
7748 :
7749 37298 : gfc_current_locus = gfc_current_ns->proc_name->declared_at;
7750 37298 : gfc_derived_types = gfc_current_ns->derived_types;
7751 37298 : gfc_generate_code (gfc_current_ns);
7752 37298 : gfc_current_ns->translated = 1;
7753 : }
7754 :
7755 : /* Clean up all the namespaces after translation. */
7756 32491 : gfc_current_ns = gfc_global_ns_list;
7757 83290 : for (;gfc_current_ns;)
7758 : {
7759 50799 : gfc_namespace *ns;
7760 :
7761 50799 : if (gfc_current_ns->proc_name
7762 50799 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
7763 : {
7764 10436 : gfc_current_ns = gfc_current_ns->sibling;
7765 10436 : continue;
7766 : }
7767 :
7768 40363 : ns = gfc_current_ns->sibling;
7769 40363 : gfc_derived_types = gfc_current_ns->derived_types;
7770 40363 : gfc_done_2 ();
7771 40363 : gfc_current_ns = ns;
7772 : }
7773 :
7774 32491 : clean_up_modules (gfc_gsym_root);
7775 32491 : }
7776 :
7777 :
7778 : /* Top level parser. */
7779 :
7780 : bool
7781 32537 : gfc_parse_file (void)
7782 : {
7783 32537 : int seen_program, errors_before, errors;
7784 32537 : gfc_state_data top, s;
7785 32537 : gfc_statement st;
7786 32537 : locus prog_locus;
7787 32537 : gfc_namespace *next;
7788 :
7789 32537 : gfc_start_source_files ();
7790 :
7791 32537 : top.state = COMP_NONE;
7792 32537 : top.sym = NULL;
7793 32537 : top.previous = NULL;
7794 32537 : top.head = top.tail = NULL;
7795 32537 : top.do_variable = NULL;
7796 :
7797 32537 : gfc_state_stack = ⊤
7798 :
7799 32537 : gfc_clear_new_st ();
7800 :
7801 32537 : gfc_statement_label = NULL;
7802 :
7803 32537 : gfc_omp_metadirective_region_count = 0;
7804 32537 : gfc_omp_metadirective_region_stack.truncate (0);
7805 32537 : gfc_omp_metadirective_region_stack.safe_push (0);
7806 32537 : gfc_in_omp_metadirective_body = false;
7807 32537 : gfc_matching_omp_context_selector = false;
7808 :
7809 32570 : 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 32537 : gfc_global_ns_list = next = NULL;
7815 :
7816 32537 : seen_program = 0;
7817 32537 : errors_before = 0;
7818 :
7819 : /* Exit early for empty files. */
7820 32537 : if (gfc_at_eof ())
7821 0 : goto done;
7822 :
7823 32537 : in_specification_block = true;
7824 50901 : loop:
7825 83438 : gfc_init_2 ();
7826 83438 : st = next_statement ();
7827 83435 : switch (st)
7828 : {
7829 32492 : case ST_NONE:
7830 32492 : gfc_done_2 ();
7831 32492 : goto done;
7832 :
7833 19887 : case ST_PROGRAM:
7834 19887 : if (seen_program)
7835 1 : goto duplicate_main;
7836 19886 : seen_program = 1;
7837 19886 : prog_locus = gfc_current_locus;
7838 :
7839 19886 : push_state (&s, COMP_PROGRAM, gfc_new_block);
7840 19886 : main_program_symbol (gfc_current_ns, gfc_new_block->name);
7841 19886 : accept_statement (st);
7842 19886 : add_global_program ();
7843 19886 : parse_progunit (ST_NONE);
7844 19867 : goto prog_units;
7845 :
7846 8815 : case ST_SUBROUTINE:
7847 8815 : add_global_procedure (true);
7848 8815 : push_state (&s, COMP_SUBROUTINE, gfc_new_block);
7849 8815 : accept_statement (st);
7850 8815 : parse_progunit (ST_NONE);
7851 8810 : 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 10184 : case ST_MODULE:
7867 10184 : push_state (&s, COMP_MODULE, gfc_new_block);
7868 10184 : accept_statement (st);
7869 :
7870 10184 : gfc_get_errors (NULL, &errors_before);
7871 10184 : 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 8711 : default:
7884 8711 : if (seen_program)
7885 1 : goto duplicate_main;
7886 8710 : seen_program = 1;
7887 8710 : prog_locus = gfc_current_locus;
7888 :
7889 8710 : push_state (&s, COMP_PROGRAM, gfc_new_block);
7890 8710 : main_program_symbol (gfc_current_ns, "MAIN__");
7891 8710 : parse_progunit (st);
7892 8698 : goto prog_units;
7893 : }
7894 :
7895 : /* Handle the non-program units. */
7896 10532 : gfc_current_ns->code = s.head;
7897 :
7898 10532 : gfc_resolve (gfc_current_ns);
7899 :
7900 : /* Fix the implicit_pure attribute for those procedures who should
7901 : not have it. */
7902 10633 : while (gfc_fix_implicit_pure (gfc_current_ns))
7903 : ;
7904 :
7905 : /* Dump the parse tree if requested. */
7906 10532 : if (flag_dump_fortran_original)
7907 0 : gfc_dump_parse_tree (gfc_current_ns, stdout);
7908 :
7909 10532 : gfc_get_errors (NULL, &errors);
7910 10532 : if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE)
7911 : {
7912 10446 : gfc_dump_module (s.sym->name, errors_before == errors);
7913 10446 : gfc_current_ns->derived_types = gfc_derived_types;
7914 10446 : gfc_derived_types = NULL;
7915 10446 : 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 50815 : 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 50815 : gfc_current_ns->code = s.head;
7932 50815 : if (next)
7933 : {
7934 18482 : for (; next->sibling; next = next->sibling)
7935 : ;
7936 18471 : next->sibling = gfc_current_ns;
7937 : }
7938 : else
7939 32344 : gfc_global_ns_list = gfc_current_ns;
7940 :
7941 50815 : next = gfc_current_ns;
7942 :
7943 50815 : pop_state ();
7944 50815 : goto loop;
7945 :
7946 32492 : done:
7947 : /* Do the resolution. */
7948 32492 : resolve_all_program_units (gfc_global_ns_list);
7949 :
7950 32491 : if (flag_coarray == GFC_FCOARRAY_LIB)
7951 531 : 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 32510 : bool changed;
7959 32510 : do
7960 : {
7961 32510 : changed = false;
7962 83334 : for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
7963 50824 : gfc_current_ns = gfc_current_ns->sibling)
7964 : {
7965 50824 : 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 32491 : int omp_requires;
7973 32491 : bool omp_target_seen;
7974 32491 : omp_requires = 0;
7975 32491 : omp_target_seen = false;
7976 83290 : for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
7977 50799 : gfc_current_ns = gfc_current_ns->sibling)
7978 : {
7979 50799 : omp_requires |= gfc_current_ns->omp_requires;
7980 50799 : omp_target_seen |= gfc_current_ns->omp_target_seen;
7981 50799 : gfc_check_externals (gfc_current_ns);
7982 : }
7983 83290 : for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
7984 50799 : gfc_current_ns = gfc_current_ns->sibling)
7985 50799 : 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 32491 : 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 32491 : if (omp_target_seen)
8019 1011 : omp_requires_mask = (enum omp_requires) (omp_requires_mask
8020 : | int (OMP_REQUIRES_TARGET_USED));
8021 32491 : if (omp_requires & OMP_REQ_REVERSE_OFFLOAD)
8022 25 : omp_requires_mask
8023 25 : = (enum omp_requires) (omp_requires_mask
8024 : | int (OMP_REQUIRES_REVERSE_OFFLOAD));
8025 32491 : if (omp_requires & OMP_REQ_UNIFIED_ADDRESS)
8026 5 : omp_requires_mask
8027 5 : = (enum omp_requires) (omp_requires_mask
8028 : | int (OMP_REQUIRES_UNIFIED_ADDRESS));
8029 32491 : if (omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
8030 7 : omp_requires_mask
8031 7 : = (enum omp_requires) (omp_requires_mask
8032 : | int (OMP_REQUIRES_UNIFIED_SHARED_MEMORY));
8033 32491 : if (omp_requires & OMP_REQ_SELF_MAPS)
8034 11 : omp_requires_mask
8035 11 : = (enum omp_requires) (omp_requires_mask | int (OMP_REQUIRES_SELF_MAPS));
8036 32491 : if (omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
8037 7 : omp_requires_mask
8038 7 : = (enum omp_requires) (omp_requires_mask
8039 : | int (OMP_REQUIRES_DYNAMIC_ALLOCATORS));
8040 : /* Do the parse tree dump. */
8041 32491 : gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL;
8042 :
8043 32531 : 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 32491 : 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 32491 : if (flag_c_prototypes)
8071 2 : gfc_dump_c_prototypes (stdout);
8072 :
8073 : /* Dump external prototypes. */
8074 32491 : if (flag_c_prototypes_external)
8075 0 : gfc_dump_external_c_prototypes (stdout);
8076 :
8077 32491 : 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 32491 : 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 32491 : if (flag_dump_fortran_global)
8088 0 : gfc_dump_global_symbols (stdout);
8089 :
8090 32491 : 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 262 : is_omp_declarative_stmt (gfc_statement st)
8138 : {
8139 262 : switch (st)
8140 : {
8141 : case_omp_decl:
8142 : return true;
8143 262 : default:
8144 262 : return false;
8145 : }
8146 : }
|
