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