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 24078739 : match_word (const char *str, match (*subr) (void), locus *old_locus,
87 : bool no_substring = false, bool reject_stmt_on_error = true)
88 : {
89 24078739 : match m;
90 24078739 : char c;
91 :
92 24078739 : if (str != NULL)
93 : {
94 14431061 : m = gfc_match (str);
95 14431061 : if (m != MATCH_YES)
96 : return m;
97 51291 : if (no_substring && gfc_current_form == FORM_FREE
98 3923626 : && ((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 13521336 : m = (*subr) ();
106 :
107 13521332 : if (m == MATCH_NO || (reject_stmt_on_error && m == MATCH_ERROR))
108 : {
109 9130659 : gfc_current_locus = *old_locus;
110 9130659 : 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 21092 : use_modules (void)
158 : {
159 21092 : gfc_error_buffer old_error;
160 :
161 21092 : gfc_push_error (&old_error);
162 21092 : gfc_buffer_error (false);
163 21092 : gfc_use_modules ();
164 21088 : gfc_buffer_error (true);
165 21088 : gfc_pop_error (&old_error);
166 21088 : gfc_commit_symbols ();
167 21088 : gfc_warning_check ();
168 21088 : gfc_current_ns->old_equiv = gfc_current_ns->equiv;
169 21088 : gfc_current_ns->old_data = gfc_current_ns->data;
170 21088 : last_was_use_stmt = false;
171 21088 : }
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 1377619 : current_interface_valid_p ()
346 : {
347 1377619 : 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 1377619 : get_current_interface_ptr ()
370 : {
371 1377619 : 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 1377619 : decode_statement (void)
386 : {
387 1377619 : gfc_statement st;
388 1377619 : locus old_locus;
389 1377619 : match m = MATCH_NO;
390 1377619 : char c;
391 :
392 1377619 : gfc_enforce_clean_symbol_state ();
393 :
394 1377619 : gfc_clear_error (); /* Clear any pending errors. */
395 1377619 : gfc_clear_warning (); /* Clear any pending warnings. */
396 :
397 1377619 : current_interface_ptr = get_current_interface_ptr ();
398 2755238 : previous_interface_head = current_interface_ptr == nullptr
399 1377619 : ? nullptr
400 : : *current_interface_ptr;
401 :
402 1377619 : gfc_matching_function = false;
403 :
404 1377619 : if (gfc_match_eos () == MATCH_YES)
405 : return ST_NONE;
406 :
407 1377606 : if (gfc_current_state () == COMP_FUNCTION
408 99134 : && gfc_current_block ()->result->ts.kind == -1)
409 10826 : return decode_specification_statement ();
410 :
411 1366780 : old_locus = gfc_current_locus;
412 :
413 1366780 : c = gfc_peek_ascii_char ();
414 :
415 1366780 : if (c == 'u')
416 : {
417 27515 : if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
418 : {
419 23013 : last_was_use_stmt = true;
420 23013 : return ST_USE;
421 : }
422 : else
423 4502 : undo_new_statement ();
424 : }
425 :
426 1343767 : if (last_was_use_stmt)
427 19755 : 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 1343764 : if (gfc_current_state () == COMP_NONE
434 : || gfc_current_state () == COMP_INTERFACE
435 : || gfc_current_state () == COMP_CONTAINS)
436 : {
437 129727 : gfc_matching_function = true;
438 129727 : m = gfc_match_function_decl ();
439 129727 : if (m == MATCH_YES)
440 : return ST_FUNCTION;
441 109623 : else if (m == MATCH_ERROR)
442 9964 : reject_statement ();
443 : else
444 99659 : gfc_undo_symbols ();
445 109623 : gfc_current_locus = old_locus;
446 : }
447 1323660 : gfc_matching_function = false;
448 :
449 : /* Legacy parameter statements are ambiguous with assignments so try parameter
450 : first. */
451 1323660 : 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 1315845 : match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
457 1034710 : match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
458 :
459 1025477 : if (in_specification_block)
460 : {
461 421677 : m = match_word (NULL, gfc_match_st_function, &old_locus);
462 421677 : if (m == MATCH_YES)
463 : return ST_STATEMENT_FUNCTION;
464 : }
465 :
466 1025250 : if (!(in_specification_block && m == MATCH_ERROR))
467 : {
468 1025229 : match (NULL, gfc_match_ptr_fcn_assign, ST_ASSIGNMENT);
469 : }
470 :
471 1025099 : match (NULL, gfc_match_data_decl, ST_DATA_DECL);
472 811013 : 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 810757 : if (gfc_match_subroutine () == MATCH_YES)
478 : return ST_SUBROUTINE;
479 767448 : gfc_undo_symbols ();
480 767448 : gfc_current_locus = old_locus;
481 :
482 767448 : 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 767184 : gfc_undo_symbols ();
490 767184 : 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 767184 : if (gfc_match_if (&st) == MATCH_YES)
498 232483 : return st;
499 534701 : gfc_undo_symbols ();
500 534701 : gfc_current_locus = old_locus;
501 :
502 534701 : if (gfc_match_where (&st) == MATCH_YES)
503 446 : return st;
504 534255 : gfc_undo_symbols ();
505 534255 : gfc_current_locus = old_locus;
506 :
507 534255 : if (gfc_match_forall (&st) == MATCH_YES)
508 1987 : return st;
509 532268 : gfc_undo_symbols ();
510 532268 : gfc_current_locus = old_locus;
511 :
512 : /* Try to match TYPE as an alias for PRINT. */
513 532268 : if (gfc_match_type (&st) == MATCH_YES)
514 19 : return st;
515 532249 : gfc_undo_symbols ();
516 532249 : gfc_current_locus = old_locus;
517 :
518 532249 : match (NULL, gfc_match_do, ST_DO);
519 499307 : match (NULL, gfc_match_block, ST_BLOCK);
520 497822 : match (NULL, gfc_match_associate, ST_ASSOCIATE);
521 496274 : match (NULL, gfc_match_change_team, ST_CHANGE_TEAM);
522 496177 : match (NULL, gfc_match_critical, ST_CRITICAL);
523 496123 : match (NULL, gfc_match_select, ST_SELECT_CASE);
524 495590 : match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
525 492506 : 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 491470 : switch (c)
532 : {
533 15316 : case 'a':
534 15316 : match ("abstract% interface", gfc_match_abstract_interface,
535 : ST_INTERFACE);
536 14842 : 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 109814 : case 'c':
550 109814 : match ("call", gfc_match_call, ST_CALL);
551 29444 : match ("close", gfc_match_close, ST_CLOSE);
552 26296 : match ("continue", gfc_match_continue, ST_CONTINUE);
553 23478 : match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
554 23474 : match ("cycle", gfc_match_cycle, ST_CYCLE);
555 23444 : match ("case", gfc_match_case, ST_CASE);
556 21853 : match ("common", gfc_match_common, ST_COMMON);
557 19837 : match ("contains", gfc_match_eos, ST_CONTAINS);
558 2276 : match ("class", gfc_match_class_is, ST_CLASS_IS);
559 281 : match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
560 269 : break;
561 :
562 8727 : case 'd':
563 8727 : 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 194868 : case 'e':
569 194868 : match ("end file", gfc_match_endfile, ST_END_FILE);
570 194797 : match ("exit", gfc_match_exit, ST_EXIT);
571 194499 : match ("else", gfc_match_else, ST_ELSE);
572 190373 : match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
573 190061 : match ("else if", gfc_match_elseif, ST_ELSEIF);
574 188124 : match ("error% stop", gfc_match_error_stop, ST_ERROR_STOP);
575 187158 : match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
576 :
577 187000 : if (gfc_match_end (&st) == MATCH_YES)
578 181633 : 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 1810 : case 'f':
588 1810 : match ("fail% image", gfc_match_fail_image, ST_FAIL_IMAGE);
589 1804 : 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 1674 : case 'g':
596 1674 : match ("generic", gfc_match_generic, ST_GENERIC);
597 646 : match ("go to", gfc_match_goto, ST_GOTO);
598 23 : break;
599 :
600 41858 : case 'i':
601 41858 : match ("inquire", gfc_match_inquire, ST_INQUIRE);
602 40928 : match ("implicit", gfc_match_implicit, ST_IMPLICIT);
603 40513 : match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
604 16450 : match ("import", gfc_match_import, ST_IMPORT);
605 12949 : 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 11787 : case 'm':
615 11787 : match ("map", gfc_match_map, ST_MAP);
616 11529 : match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC);
617 9930 : match ("module", gfc_match_module, ST_MODULE);
618 28 : break;
619 :
620 1629 : case 'n':
621 1629 : match ("nullify", gfc_match_nullify, ST_NULLIFY);
622 1052 : match ("namelist", gfc_match_namelist, ST_NAMELIST);
623 17 : break;
624 :
625 4197 : case 'o':
626 4197 : match ("open", gfc_match_open, ST_OPEN);
627 242 : match ("optional", gfc_match_optional, ST_ATTR_DECL);
628 25 : break;
629 :
630 37291 : case 'p':
631 37291 : match ("print", gfc_match_print, ST_WRITE);
632 30060 : match ("pause", gfc_match_pause, ST_PAUSE);
633 30030 : match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
634 29144 : if (gfc_match_private (&st) == MATCH_YES)
635 1628 : return st;
636 27516 : match ("procedure", gfc_match_procedure, ST_PROCEDURE);
637 21160 : match ("program", gfc_match_program, ST_PROGRAM);
638 1777 : if (gfc_match_public (&st) == MATCH_YES)
639 1521 : return st;
640 256 : match ("protected", gfc_match_protected, ST_ATTR_DECL);
641 239 : break;
642 :
643 14153 : case 'r':
644 14153 : match ("rank", gfc_match_rank_is, ST_RANK);
645 11809 : match ("read", gfc_match_read, ST_READ);
646 5249 : match ("return", gfc_match_return, ST_RETURN);
647 2433 : match ("rewind", gfc_match_rewind, ST_REWIND);
648 156 : break;
649 :
650 11324 : case 's':
651 11324 : match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL);
652 11026 : match ("sequence", gfc_match_eos, ST_SEQUENCE);
653 10786 : 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 16762 : case 't':
664 16762 : match ("target", gfc_match_target, ST_ATTR_DECL);
665 16667 : match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
666 3629 : 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 19146 : case 'w':
680 19146 : match ("wait", gfc_match_wait, ST_WAIT);
681 19057 : 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 2338 : 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 2336 : reject_statement ();
698 :
699 2336 : gfc_error_recovery ();
700 :
701 2336 : 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 : 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 : 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 3454402 : decode_gcc_attribute (void)
1519 : {
1520 3454402 : locus old_locus;
1521 :
1522 3454402 : gfc_enforce_clean_symbol_state ();
1523 :
1524 3454402 : gfc_clear_error (); /* Clear any pending errors. */
1525 3454402 : gfc_clear_warning (); /* Clear any pending warnings. */
1526 3454402 : old_locus = gfc_current_locus;
1527 :
1528 3454402 : match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL);
1529 3451418 : match ("unroll", gfc_match_gcc_unroll, ST_NONE);
1530 3451401 : 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 4606797 : next_free (void)
1577 : {
1578 4606797 : match m;
1579 4606797 : int i, cnt, at_bol;
1580 4606797 : char c;
1581 :
1582 4606797 : at_bol = gfc_at_bol ();
1583 4606797 : gfc_gobble_whitespace ();
1584 :
1585 4606797 : c = gfc_peek_ascii_char ();
1586 :
1587 4606797 : 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 4 : 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 4604525 : 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 3315209 : gfc_next_ascii_char (); /* Eat up the exclamation sign. */
1639 3315209 : c = gfc_peek_ascii_char ();
1640 :
1641 3315209 : if (c == 'g')
1642 : {
1643 3261430 : int i;
1644 :
1645 3261430 : c = gfc_next_ascii_char ();
1646 19568580 : for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
1647 13045720 : gcc_assert (c == "gcc$"[i]);
1648 :
1649 3261430 : gfc_gobble_whitespace ();
1650 3261430 : 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 1291582 : 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 1291575 : 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 280351 : next_fixed (void)
1728 : {
1729 280351 : int label, digit_flag, i;
1730 280351 : locus loc;
1731 280351 : gfc_char_t c;
1732 :
1733 280351 : 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 710336 : for (i = 0; i < 5; i++)
1746 : {
1747 624330 : c = gfc_next_char_literal (NONSTRING);
1748 :
1749 624330 : 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 194297 : case '*':
1773 194297 : c = gfc_next_char_literal (NONSTRING);
1774 :
1775 194297 : if (TOLOWER (c) == 'g')
1776 : {
1777 964860 : for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
1778 771888 : gcc_assert (TOLOWER (c) == "gcc$"[i]);
1779 :
1780 192972 : 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 86006 : 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 86006 : c = gfc_next_char_literal (NONSTRING);
1843 86006 : if (c == '\n')
1844 0 : goto blank_line;
1845 :
1846 86006 : 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 238273 : do
1858 : {
1859 238273 : loc = gfc_current_locus;
1860 238273 : c = gfc_next_char_literal (NONSTRING);
1861 : }
1862 238273 : while (gfc_is_whitespace (c));
1863 :
1864 86006 : if (c == '!')
1865 0 : goto blank_line;
1866 86006 : gfc_current_locus = loc;
1867 :
1868 86006 : 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 6 : return ST_NONE;
1876 : }
1877 :
1878 86000 : 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 85999 : 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 1464029 : next_statement (void)
1899 : {
1900 1464029 : gfc_statement st;
1901 1464029 : locus old_locus;
1902 :
1903 1464029 : gfc_enforce_clean_symbol_state ();
1904 1464029 : gfc_save_module_list ();
1905 :
1906 1464029 : gfc_new_block = NULL;
1907 :
1908 1464029 : gfc_current_ns->old_equiv = gfc_current_ns->equiv;
1909 1464029 : gfc_current_ns->old_data = gfc_current_ns->data;
1910 4919111 : for (;;)
1911 : {
1912 4919111 : gfc_statement_label = NULL;
1913 4919111 : gfc_buffer_error (true);
1914 :
1915 4919111 : if (gfc_at_eol ())
1916 4848794 : gfc_advance_line ();
1917 :
1918 4919111 : gfc_skip_comments ();
1919 :
1920 4919111 : if (gfc_at_end ())
1921 : {
1922 : st = ST_NONE;
1923 : break;
1924 : }
1925 :
1926 4887156 : if (gfc_define_undef_line ())
1927 8 : continue;
1928 :
1929 4887148 : old_locus = gfc_current_locus;
1930 :
1931 4887148 : st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
1932 :
1933 4887139 : if (st != ST_NONE)
1934 : break;
1935 : }
1936 :
1937 1464020 : gfc_buffer_error (false);
1938 :
1939 1464020 : 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 1464020 : if (st != ST_NONE)
1950 1432065 : check_statement_label (st);
1951 :
1952 1464020 : 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 228730 : push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
2094 : {
2095 228730 : p->state = new_state;
2096 228730 : p->previous = gfc_state_stack;
2097 228730 : p->sym = sym;
2098 228730 : p->head = p->tail = NULL;
2099 228730 : p->do_variable = NULL;
2100 228730 : if (p->state != COMP_DO && p->state != COMP_DO_CONCURRENT)
2101 195792 : 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 228730 : gcc_assert (gfc_state_stack);
2107 228730 : p->construct = gfc_state_stack->tail;
2108 :
2109 228730 : gfc_state_stack = p;
2110 228730 : }
2111 :
2112 :
2113 : /* Pop the current state. */
2114 : static void
2115 228239 : pop_state (void)
2116 : {
2117 228239 : gfc_state_stack = gfc_state_stack->previous;
2118 37072 : }
2119 :
2120 :
2121 : /* Try to find the given state in the state stack. */
2122 :
2123 : bool
2124 4493227 : gfc_find_state (gfc_compile_state state)
2125 : {
2126 4493227 : gfc_state_data *p;
2127 :
2128 18062363 : for (p = gfc_state_stack; p; p = p->previous)
2129 13671475 : if (p->state == state)
2130 : break;
2131 :
2132 4493227 : return p != NULL;
2133 : }
2134 :
2135 :
2136 : /* Starts a new level in the statement list. */
2137 :
2138 : static gfc_code *
2139 76071 : new_level (gfc_code *q)
2140 : {
2141 76071 : gfc_code *p;
2142 :
2143 76071 : p = q->block = gfc_get_code (EXEC_NOP);
2144 :
2145 76071 : gfc_state_stack->head = gfc_state_stack->tail = p;
2146 :
2147 76071 : 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 857458 : add_statement (void)
2156 : {
2157 857458 : gfc_code *p;
2158 :
2159 857458 : p = XCNEW (gfc_code);
2160 857458 : *p = new_st;
2161 :
2162 857458 : p->loc = gfc_current_locus;
2163 :
2164 857458 : if (gfc_state_stack->head == NULL)
2165 103290 : gfc_state_stack->head = p;
2166 : else
2167 754168 : gfc_state_stack->tail->next = p;
2168 :
2169 858011 : while (p->next != NULL)
2170 : p = p->next;
2171 :
2172 857458 : gfc_state_stack->tail = p;
2173 :
2174 857458 : gfc_clear_new_st ();
2175 :
2176 857458 : return p;
2177 : }
2178 :
2179 :
2180 : /* Frees everything associated with the current statement. */
2181 :
2182 : static void
2183 28578199 : undo_new_statement (void)
2184 : {
2185 28578199 : gfc_free_statements (new_st.block);
2186 28578199 : gfc_free_statements (new_st.next);
2187 28578199 : gfc_free_statement (&new_st);
2188 28578199 : gfc_clear_new_st ();
2189 28578199 : }
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 1432065 : check_statement_label (gfc_statement st)
2197 : {
2198 1432065 : gfc_sl_type type;
2199 :
2200 1432065 : if (gfc_statement_label == NULL)
2201 : {
2202 1427367 : if (st == ST_FORMAT)
2203 0 : gfc_error ("FORMAT statement at %L does not have a statement label",
2204 : &new_st.loc);
2205 1427367 : 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 1027218 : gfc_enclosing_unit (gfc_compile_state * result)
2252 : {
2253 1027218 : gfc_state_data *p;
2254 :
2255 1488936 : for (p = gfc_state_stack; p; p = p->previous)
2256 1444118 : 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 982400 : if (result != NULL)
2262 3205 : *result = p->state;
2263 982400 : return p;
2264 : }
2265 :
2266 44818 : 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 29603 : gfc_ascii_statement (gfc_statement st, bool strip_sentinel)
2277 : {
2278 29603 : const char *p;
2279 :
2280 29603 : 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 2877 : case ST_END_SUBROUTINE:
2424 2877 : p = "END SUBROUTINE";
2425 2877 : 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 24221 : case ST_IMPLICIT:
2476 24221 : p = "IMPLICIT";
2477 24221 : 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 29603 : 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 28046 : main_program_symbol (gfc_namespace *ns, const char *name)
3177 : {
3178 28046 : gfc_symbol *main_program;
3179 28046 : symbol_attribute attr;
3180 :
3181 28046 : gfc_get_symbol (name, ns, &main_program);
3182 28046 : gfc_clear_attr (&attr);
3183 28046 : attr.flavor = FL_PROGRAM;
3184 28046 : attr.proc = PROC_UNKNOWN;
3185 28046 : attr.subroutine = 1;
3186 28046 : attr.access = ACCESS_PUBLIC;
3187 28046 : attr.is_main_program = 1;
3188 28046 : main_program->attr = attr;
3189 28046 : main_program->declared_at = gfc_current_locus;
3190 28046 : ns->proc_name = main_program;
3191 28046 : gfc_commit_symbols ();
3192 28046 : }
3193 :
3194 :
3195 : /* Do whatever is necessary to accept the last statement. */
3196 :
3197 : static void
3198 1396545 : accept_statement (gfc_statement st)
3199 : {
3200 1396545 : switch (st)
3201 : {
3202 : case ST_IMPLICIT_NONE:
3203 : case ST_IMPLICIT:
3204 : break;
3205 :
3206 73841 : case ST_FUNCTION:
3207 73841 : case ST_SUBROUTINE:
3208 73841 : case ST_MODULE:
3209 73841 : case ST_SUBMODULE:
3210 73841 : gfc_current_ns->proc_name = gfc_new_block;
3211 73841 : 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 19641 : case ST_ENDIF:
3226 19641 : case ST_END_SELECT:
3227 19641 : case ST_END_CRITICAL:
3228 19641 : 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 3018 : case ST_END_BLOCK:
3239 3018 : case ST_END_ASSOCIATE:
3240 3018 : 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 76822 : case ST_END_PROGRAM:
3252 76822 : case ST_END_FUNCTION:
3253 76822 : case ST_END_SUBROUTINE:
3254 76822 : if (gfc_statement_label != NULL)
3255 : {
3256 20 : new_st.op = EXEC_RETURN;
3257 20 : add_statement ();
3258 : }
3259 : else
3260 : {
3261 76802 : new_st.op = EXEC_END_PROCEDURE;
3262 76802 : add_statement ();
3263 : }
3264 :
3265 : break;
3266 :
3267 764622 : case ST_ENTRY:
3268 764622 : case ST_OMP_METADIRECTIVE:
3269 764622 : case ST_OMP_BEGIN_METADIRECTIVE:
3270 764622 : case ST_CHANGE_TEAM:
3271 764622 : case ST_END_TEAM:
3272 764622 : case_executable:
3273 764622 : case_exec_markers:
3274 764622 : add_statement ();
3275 764622 : break;
3276 :
3277 : default:
3278 : break;
3279 : }
3280 :
3281 1396545 : gfc_commit_symbols ();
3282 1396545 : gfc_warning_check ();
3283 1396545 : gfc_clear_new_st ();
3284 1396545 : }
3285 :
3286 :
3287 : /* Undo anything tentative that has been built for the current statement,
3288 : except if a gfc_charlen structure has been added to current namespace's
3289 : list of gfc_charlen structure. */
3290 :
3291 : static void
3292 9144837 : reject_statement (void)
3293 : {
3294 9144837 : gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv);
3295 9144837 : gfc_current_ns->equiv = gfc_current_ns->old_equiv;
3296 9144837 : gfc_drop_interface_elements_before (current_interface_ptr,
3297 : previous_interface_head);
3298 :
3299 9144837 : gfc_reject_data (gfc_current_ns);
3300 :
3301 : /* Don't queue use-association of a module if we reject the use statement. */
3302 9144837 : gfc_restore_old_module_list ();
3303 :
3304 9144837 : gfc_new_block = NULL;
3305 9144837 : gfc_undo_symbols ();
3306 9144837 : gfc_clear_warning ();
3307 9144837 : undo_new_statement ();
3308 9144837 : }
3309 :
3310 :
3311 : /* Generic complaint about an out of order statement. We also do
3312 : whatever is necessary to clean up. */
3313 :
3314 : static void
3315 270 : unexpected_statement (gfc_statement st)
3316 : {
3317 270 : gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
3318 :
3319 270 : reject_statement ();
3320 270 : }
3321 :
3322 :
3323 : /* Given the next statement seen by the matcher, make sure that it is
3324 : in proper order with the last. This subroutine is initialized by
3325 : calling it with an argument of ST_NONE. If there is a problem, we
3326 : issue an error and return false. Otherwise we return true.
3327 :
3328 : Individual parsers need to verify that the statements seen are
3329 : valid before calling here, i.e., ENTRY statements are not allowed in
3330 : INTERFACE blocks. The following diagram is taken from the standard:
3331 :
3332 : +---------------------------------------+
3333 : | program subroutine function module |
3334 : +---------------------------------------+
3335 : | use |
3336 : +---------------------------------------+
3337 : | import |
3338 : +---------------------------------------+
3339 : | | implicit none |
3340 : | +-----------+------------------+
3341 : | | parameter | implicit |
3342 : | +-----------+------------------+
3343 : | format | | derived type |
3344 : | entry | parameter | interface |
3345 : | | data | specification |
3346 : | | | statement func |
3347 : | +-----------+------------------+
3348 : | | data | executable |
3349 : +--------+-----------+------------------+
3350 : | contains |
3351 : +---------------------------------------+
3352 : | internal module/subprogram |
3353 : +---------------------------------------+
3354 : | end |
3355 : +---------------------------------------+
3356 :
3357 : */
3358 :
3359 : enum state_order
3360 : {
3361 : ORDER_START,
3362 : ORDER_USE,
3363 : ORDER_IMPORT,
3364 : ORDER_IMPLICIT_NONE,
3365 : ORDER_IMPLICIT,
3366 : ORDER_SPEC,
3367 : ORDER_EXEC
3368 : };
3369 :
3370 : typedef struct
3371 : {
3372 : enum state_order state;
3373 : gfc_statement last_statement;
3374 : locus where;
3375 : }
3376 : st_state;
3377 :
3378 : static bool
3379 451004 : verify_st_order (st_state *p, gfc_statement st, bool silent)
3380 : {
3381 :
3382 451004 : switch (st)
3383 : {
3384 116421 : case ST_NONE:
3385 116421 : p->state = ORDER_START;
3386 116421 : in_exec_part = false;
3387 116421 : break;
3388 :
3389 25321 : case ST_USE:
3390 25321 : if (p->state > ORDER_USE)
3391 0 : goto order;
3392 25321 : p->state = ORDER_USE;
3393 25321 : break;
3394 :
3395 4524 : case ST_IMPORT:
3396 4524 : if (p->state > ORDER_IMPORT)
3397 0 : goto order;
3398 4524 : p->state = ORDER_IMPORT;
3399 4524 : break;
3400 :
3401 24872 : case ST_IMPLICIT_NONE:
3402 24872 : if (p->state > ORDER_IMPLICIT)
3403 0 : goto order;
3404 :
3405 : /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
3406 : statement disqualifies a USE but not an IMPLICIT NONE.
3407 : Duplicate IMPLICIT NONEs are caught when the implicit types
3408 : are set. */
3409 :
3410 24872 : p->state = ORDER_IMPLICIT_NONE;
3411 24872 : break;
3412 :
3413 13407 : case ST_IMPLICIT:
3414 13407 : if (p->state > ORDER_IMPLICIT)
3415 10282 : goto order;
3416 3125 : p->state = ORDER_IMPLICIT;
3417 3125 : break;
3418 :
3419 494 : case ST_FORMAT:
3420 494 : case ST_ENTRY:
3421 494 : if (p->state < ORDER_IMPLICIT_NONE)
3422 77 : p->state = ORDER_IMPLICIT_NONE;
3423 : break;
3424 :
3425 7815 : case ST_PARAMETER:
3426 7815 : if (p->state >= ORDER_EXEC)
3427 0 : goto order;
3428 7815 : if (p->state < ORDER_IMPLICIT)
3429 80 : p->state = ORDER_IMPLICIT;
3430 : break;
3431 :
3432 2340 : case ST_DATA:
3433 2340 : if (p->state < ORDER_SPEC)
3434 17 : p->state = ORDER_SPEC;
3435 : break;
3436 :
3437 252131 : case ST_PUBLIC:
3438 252131 : case ST_PRIVATE:
3439 252131 : case ST_STRUCTURE_DECL:
3440 252131 : case ST_DERIVED_DECL:
3441 252131 : case_decl:
3442 252131 : if (p->state >= ORDER_EXEC)
3443 0 : goto order;
3444 252131 : if (p->state < ORDER_SPEC)
3445 100009 : p->state = ORDER_SPEC;
3446 : break;
3447 :
3448 2918 : case_omp_decl:
3449 : /* The OpenMP/OpenACC directives have to be somewhere in the specification
3450 : part, but there are no further requirements on their ordering.
3451 : Thus don't adjust p->state, just ignore them. */
3452 2918 : if (p->state >= ORDER_EXEC)
3453 0 : goto order;
3454 : break;
3455 :
3456 757 : case ST_CHANGE_TEAM:
3457 757 : case ST_END_TEAM:
3458 757 : case_executable:
3459 757 : case_exec_markers:
3460 757 : if (p->state < ORDER_EXEC)
3461 757 : p->state = ORDER_EXEC;
3462 757 : in_exec_part = true;
3463 757 : break;
3464 :
3465 : default:
3466 : return false;
3467 : }
3468 :
3469 : /* All is well, record the statement in case we need it next time. */
3470 440718 : p->where = gfc_current_locus;
3471 440718 : p->last_statement = st;
3472 440718 : return true;
3473 :
3474 10282 : order:
3475 10282 : if (!silent)
3476 1 : gfc_error ("%s statement at %C cannot follow %s statement at %L",
3477 : gfc_ascii_statement (st),
3478 : gfc_ascii_statement (p->last_statement), &p->where);
3479 :
3480 : return false;
3481 : }
3482 :
3483 :
3484 : /* Handle an unexpected end of file. This is a show-stopper... */
3485 :
3486 : static void unexpected_eof (void) ATTRIBUTE_NORETURN;
3487 :
3488 : static void
3489 33 : unexpected_eof (void)
3490 : {
3491 33 : gfc_state_data *p;
3492 :
3493 33 : gfc_error ("Unexpected end of file in %qs", gfc_source_file);
3494 :
3495 : /* Memory cleanup. Move to "second to last". */
3496 72 : for (p = gfc_state_stack; p && p->previous && p->previous->previous;
3497 : p = p->previous);
3498 :
3499 33 : gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
3500 33 : gfc_done_2 ();
3501 :
3502 33 : longjmp (eof_buf, 1);
3503 :
3504 : /* Avoids build error on systems where longjmp is not declared noreturn. */
3505 : gcc_unreachable ();
3506 : }
3507 :
3508 :
3509 : /* Parse the CONTAINS section of a derived type definition. */
3510 :
3511 : gfc_access gfc_typebound_default_access;
3512 :
3513 : static bool
3514 2311 : parse_derived_contains (void)
3515 : {
3516 2311 : gfc_state_data s;
3517 2311 : bool seen_private = false;
3518 2311 : bool seen_comps = false;
3519 2311 : bool error_flag = false;
3520 2311 : bool to_finish;
3521 :
3522 2311 : gcc_assert (gfc_current_state () == COMP_DERIVED);
3523 2311 : gcc_assert (gfc_current_block ());
3524 :
3525 : /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
3526 : section. */
3527 2311 : if (gfc_current_block ()->attr.sequence)
3528 1 : gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
3529 : " section at %C", gfc_current_block ()->name);
3530 2311 : if (gfc_current_block ()->attr.is_bind_c)
3531 1 : gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
3532 : " section at %C", gfc_current_block ()->name);
3533 :
3534 2311 : accept_statement (ST_CONTAINS);
3535 2311 : push_state (&s, COMP_DERIVED_CONTAINS, NULL);
3536 :
3537 2311 : gfc_typebound_default_access = ACCESS_PUBLIC;
3538 :
3539 2311 : to_finish = false;
3540 2311 : while (!to_finish)
3541 : {
3542 6961 : gfc_statement st;
3543 6961 : st = next_statement ();
3544 6961 : switch (st)
3545 : {
3546 0 : case ST_NONE:
3547 0 : unexpected_eof ();
3548 1 : break;
3549 :
3550 1 : case ST_DATA_DECL:
3551 1 : gfc_error ("Components in TYPE at %C must precede CONTAINS");
3552 1 : goto error;
3553 :
3554 3205 : case ST_PROCEDURE:
3555 3205 : if (!gfc_notify_std (GFC_STD_F2003, "Type-bound procedure at %C"))
3556 0 : goto error;
3557 :
3558 3205 : accept_statement (ST_PROCEDURE);
3559 3205 : seen_comps = true;
3560 3205 : break;
3561 :
3562 940 : case ST_GENERIC:
3563 940 : if (!gfc_notify_std (GFC_STD_F2003, "GENERIC binding at %C"))
3564 0 : goto error;
3565 :
3566 940 : accept_statement (ST_GENERIC);
3567 940 : seen_comps = true;
3568 940 : break;
3569 :
3570 471 : case ST_FINAL:
3571 471 : if (!gfc_notify_std (GFC_STD_F2003, "FINAL procedure declaration"
3572 : " at %C"))
3573 1 : goto error;
3574 :
3575 470 : accept_statement (ST_FINAL);
3576 470 : seen_comps = true;
3577 470 : break;
3578 :
3579 2311 : case ST_END_TYPE:
3580 2311 : to_finish = true;
3581 :
3582 2311 : if (!seen_comps
3583 2311 : && (!gfc_notify_std(GFC_STD_F2008, "Derived type definition "
3584 : "at %C with empty CONTAINS section")))
3585 4 : goto error;
3586 :
3587 : /* ST_END_TYPE is accepted by parse_derived after return. */
3588 : break;
3589 :
3590 32 : case ST_PRIVATE:
3591 32 : if (!gfc_find_state (COMP_MODULE))
3592 : {
3593 0 : gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3594 : "a MODULE");
3595 0 : goto error;
3596 : }
3597 :
3598 32 : if (seen_comps)
3599 : {
3600 1 : gfc_error ("PRIVATE statement at %C must precede procedure"
3601 : " bindings");
3602 1 : goto error;
3603 : }
3604 :
3605 31 : if (seen_private)
3606 : {
3607 0 : gfc_error ("Duplicate PRIVATE statement at %C");
3608 0 : goto error;
3609 : }
3610 :
3611 31 : accept_statement (ST_PRIVATE);
3612 31 : gfc_typebound_default_access = ACCESS_PRIVATE;
3613 31 : seen_private = true;
3614 31 : break;
3615 :
3616 0 : case ST_SEQUENCE:
3617 0 : gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
3618 0 : goto error;
3619 :
3620 1 : case ST_CONTAINS:
3621 1 : gfc_error ("Already inside a CONTAINS block at %C");
3622 1 : goto error;
3623 :
3624 0 : default:
3625 0 : unexpected_statement (st);
3626 0 : break;
3627 : }
3628 :
3629 6953 : continue;
3630 :
3631 8 : error:
3632 8 : error_flag = true;
3633 8 : reject_statement ();
3634 6953 : }
3635 :
3636 2311 : pop_state ();
3637 2311 : gcc_assert (gfc_current_state () == COMP_DERIVED);
3638 :
3639 2311 : return error_flag;
3640 : }
3641 :
3642 :
3643 : /* Set attributes for the parent symbol based on the attributes of a component
3644 : and raise errors if conflicting attributes are found for the component. */
3645 :
3646 : static void
3647 20510 : check_component (gfc_symbol *sym, gfc_component *c, gfc_component **lockp,
3648 : gfc_component **eventp)
3649 : {
3650 20510 : bool coarray, lock_type, event_type, allocatable, pointer;
3651 20510 : coarray = lock_type = event_type = allocatable = pointer = false;
3652 20510 : gfc_component *lock_comp = NULL, *event_comp = NULL;
3653 :
3654 20510 : if (lockp) lock_comp = *lockp;
3655 20510 : if (eventp) event_comp = *eventp;
3656 :
3657 : /* Look for allocatable components. */
3658 20510 : if (c->attr.allocatable
3659 17342 : || (c->ts.type == BT_CLASS && c->attr.class_ok
3660 840 : && CLASS_DATA (c)->attr.allocatable)
3661 16788 : || (c->ts.type == BT_DERIVED && !c->attr.pointer
3662 3066 : && c->ts.u.derived->attr.alloc_comp))
3663 : {
3664 4259 : allocatable = true;
3665 4259 : sym->attr.alloc_comp = 1;
3666 : }
3667 :
3668 : /* Look for pointer components. */
3669 20510 : if (c->attr.pointer
3670 19173 : || (c->ts.type == BT_CLASS && c->attr.class_ok
3671 840 : && CLASS_DATA (c)->attr.class_pointer)
3672 18887 : || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
3673 : {
3674 1850 : pointer = true;
3675 1850 : sym->attr.pointer_comp = 1;
3676 : }
3677 :
3678 : /* Look for procedure pointer components. */
3679 20510 : if (c->attr.proc_pointer
3680 20084 : || (c->ts.type == BT_DERIVED
3681 4341 : && c->ts.u.derived->attr.proc_pointer_comp))
3682 510 : sym->attr.proc_pointer_comp = 1;
3683 :
3684 : /* Looking for coarray components. */
3685 20510 : if (c->attr.codimension
3686 20419 : || (c->ts.type == BT_CLASS && c->attr.class_ok
3687 840 : && CLASS_DATA (c)->attr.codimension))
3688 : {
3689 113 : coarray = true;
3690 113 : sym->attr.coarray_comp = 1;
3691 : }
3692 :
3693 20510 : if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
3694 12 : && !c->attr.pointer)
3695 : {
3696 11 : coarray = true;
3697 11 : sym->attr.coarray_comp = 1;
3698 : }
3699 :
3700 : /* Looking for lock_type components. */
3701 20510 : if ((c->ts.type == BT_DERIVED
3702 4348 : && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
3703 19 : && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
3704 20491 : || (c->ts.type == BT_CLASS && c->attr.class_ok
3705 840 : && CLASS_DATA (c)->ts.u.derived->from_intmod
3706 : == INTMOD_ISO_FORTRAN_ENV
3707 0 : && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
3708 : == ISOFORTRAN_LOCK_TYPE)
3709 20491 : || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp
3710 6 : && !allocatable && !pointer))
3711 : {
3712 22 : lock_type = 1;
3713 22 : lock_comp = c;
3714 22 : sym->attr.lock_comp = 1;
3715 : }
3716 :
3717 : /* Looking for event_type components. */
3718 20510 : if ((c->ts.type == BT_DERIVED
3719 4348 : && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
3720 19 : && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
3721 20510 : || (c->ts.type == BT_CLASS && c->attr.class_ok
3722 840 : && CLASS_DATA (c)->ts.u.derived->from_intmod
3723 : == INTMOD_ISO_FORTRAN_ENV
3724 0 : && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
3725 : == ISOFORTRAN_EVENT_TYPE)
3726 20510 : || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp
3727 0 : && !allocatable && !pointer))
3728 : {
3729 0 : event_type = 1;
3730 0 : event_comp = c;
3731 0 : sym->attr.event_comp = 1;
3732 : }
3733 :
3734 : /* Check for F2008, C1302 - and recall that pointers may not be coarrays
3735 : (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
3736 : unless there are nondirect [allocatable or pointer] components
3737 : involved (cf. 1.3.33.1 and 1.3.33.3). */
3738 :
3739 20510 : if (pointer && !coarray && lock_type)
3740 1 : gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
3741 : "codimension or be a subcomponent of a coarray, "
3742 : "which is not possible as the component has the "
3743 : "pointer attribute", c->name, &c->loc);
3744 20509 : else if (pointer && !coarray && c->ts.type == BT_DERIVED
3745 723 : && c->ts.u.derived->attr.lock_comp)
3746 2 : gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3747 : "of type LOCK_TYPE, which must have a codimension or be a "
3748 : "subcomponent of a coarray", c->name, &c->loc);
3749 :
3750 20510 : if (lock_type && allocatable && !coarray && c->ts.type == BT_DERIVED
3751 3 : && c->ts.u.derived->attr.lock_comp)
3752 0 : gfc_error ("Allocatable component %s at %L must have a codimension as "
3753 : "it has a noncoarray subcomponent of type LOCK_TYPE",
3754 : c->name, &c->loc);
3755 :
3756 20510 : if (sym->attr.coarray_comp && !coarray && lock_type)
3757 1 : gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3758 : "subcomponent of type LOCK_TYPE must have a codimension or "
3759 : "be a subcomponent of a coarray. (Variables of type %s may "
3760 : "not have a codimension as already a coarray "
3761 : "subcomponent exists)", c->name, &c->loc, sym->name);
3762 :
3763 20510 : if (sym->attr.lock_comp && coarray && !lock_type)
3764 1 : gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3765 : "subcomponent of type LOCK_TYPE must have a codimension or "
3766 : "be a subcomponent of a coarray. (Variables of type %s may "
3767 : "not have a codimension as %s at %L has a codimension or a "
3768 : "coarray subcomponent)", lock_comp->name, &lock_comp->loc,
3769 : sym->name, c->name, &c->loc);
3770 :
3771 : /* Similarly for EVENT TYPE. */
3772 :
3773 20510 : if (pointer && !coarray && event_type)
3774 0 : gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
3775 : "codimension or be a subcomponent of a coarray, "
3776 : "which is not possible as the component has the "
3777 : "pointer attribute", c->name, &c->loc);
3778 20510 : else if (pointer && !coarray && c->ts.type == BT_DERIVED
3779 724 : && c->ts.u.derived->attr.event_comp)
3780 0 : gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3781 : "of type EVENT_TYPE, which must have a codimension or be a "
3782 : "subcomponent of a coarray", c->name, &c->loc);
3783 :
3784 20510 : if (event_type && allocatable && !coarray)
3785 0 : gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
3786 : "a codimension", c->name, &c->loc);
3787 20510 : else if (event_type && allocatable && c->ts.type == BT_DERIVED
3788 0 : && c->ts.u.derived->attr.event_comp)
3789 0 : gfc_error ("Allocatable component %s at %L must have a codimension as "
3790 : "it has a noncoarray subcomponent of type EVENT_TYPE",
3791 : c->name, &c->loc);
3792 :
3793 20510 : if (sym->attr.coarray_comp && !coarray && event_type)
3794 0 : gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3795 : "subcomponent of type EVENT_TYPE must have a codimension or "
3796 : "be a subcomponent of a coarray. (Variables of type %s may "
3797 : "not have a codimension as already a coarray "
3798 : "subcomponent exists)", c->name, &c->loc, sym->name);
3799 :
3800 20510 : if (sym->attr.event_comp && coarray && !event_type)
3801 0 : gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3802 : "subcomponent of type EVENT_TYPE must have a codimension or "
3803 : "be a subcomponent of a coarray. (Variables of type %s may "
3804 : "not have a codimension as %s at %L has a codimension or a "
3805 : "coarray subcomponent)", event_comp->name, &event_comp->loc,
3806 : sym->name, c->name, &c->loc);
3807 :
3808 : /* Look for private components. */
3809 20510 : if (sym->component_access == ACCESS_PRIVATE
3810 20033 : || c->attr.access == ACCESS_PRIVATE
3811 19893 : || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
3812 910 : sym->attr.private_comp = 1;
3813 :
3814 20510 : if (lockp) *lockp = lock_comp;
3815 20510 : if (eventp) *eventp = event_comp;
3816 20510 : }
3817 :
3818 :
3819 : static void parse_struct_map (gfc_statement);
3820 :
3821 : /* Parse a union component definition within a structure definition. */
3822 :
3823 : static void
3824 132 : parse_union (void)
3825 : {
3826 132 : int compiling;
3827 132 : gfc_statement st;
3828 132 : gfc_state_data s;
3829 132 : gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
3830 132 : gfc_symbol *un;
3831 :
3832 132 : accept_statement(ST_UNION);
3833 132 : push_state (&s, COMP_UNION, gfc_new_block);
3834 132 : un = gfc_new_block;
3835 :
3836 132 : compiling = 1;
3837 :
3838 132 : while (compiling)
3839 : {
3840 391 : st = next_statement ();
3841 : /* Only MAP declarations valid within a union. */
3842 391 : switch (st)
3843 : {
3844 0 : case ST_NONE:
3845 0 : unexpected_eof ();
3846 :
3847 257 : case ST_MAP:
3848 257 : accept_statement (ST_MAP);
3849 257 : parse_struct_map (ST_MAP);
3850 : /* Add a component to the union for each map. */
3851 257 : if (!gfc_add_component (un, gfc_new_block->name, &c))
3852 : {
3853 0 : gfc_internal_error ("failed to create map component '%s'",
3854 : gfc_new_block->name);
3855 : reject_statement ();
3856 : return;
3857 : }
3858 257 : c->ts.type = BT_DERIVED;
3859 257 : c->ts.u.derived = gfc_new_block;
3860 : /* Normally components get their initialization expressions when they
3861 : are created in decl.cc (build_struct) so we can look through the
3862 : flat component list for initializers during resolution. Unions and
3863 : maps create components along with their type definitions so we
3864 : have to generate initializers here. */
3865 257 : c->initializer = gfc_default_initializer (&c->ts);
3866 257 : break;
3867 :
3868 132 : case ST_END_UNION:
3869 132 : compiling = 0;
3870 132 : accept_statement (ST_END_UNION);
3871 132 : break;
3872 :
3873 2 : default:
3874 2 : unexpected_statement (st);
3875 2 : break;
3876 : }
3877 : }
3878 :
3879 389 : for (c = un->components; c; c = c->next)
3880 257 : check_component (un, c, &lock_comp, &event_comp);
3881 :
3882 : /* Add the union as a component in its parent structure. */
3883 132 : pop_state ();
3884 132 : if (!gfc_add_component (gfc_current_block (), un->name, &c))
3885 : {
3886 0 : gfc_internal_error ("failed to create union component '%s'", un->name);
3887 : reject_statement ();
3888 : return;
3889 : }
3890 132 : c->ts.type = BT_UNION;
3891 132 : c->ts.u.derived = un;
3892 132 : c->initializer = gfc_default_initializer (&c->ts);
3893 :
3894 132 : un->attr.zero_comp = un->components == NULL;
3895 : }
3896 :
3897 :
3898 : /* Parse a STRUCTURE or MAP. */
3899 :
3900 : static void
3901 570 : parse_struct_map (gfc_statement block)
3902 : {
3903 570 : int compiling_type;
3904 570 : gfc_statement st;
3905 570 : gfc_state_data s;
3906 570 : gfc_symbol *sym;
3907 570 : gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
3908 570 : gfc_compile_state comp;
3909 570 : gfc_statement ends;
3910 :
3911 570 : if (block == ST_STRUCTURE_DECL)
3912 : {
3913 : comp = COMP_STRUCTURE;
3914 : ends = ST_END_STRUCTURE;
3915 : }
3916 : else
3917 : {
3918 257 : gcc_assert (block == ST_MAP);
3919 : comp = COMP_MAP;
3920 : ends = ST_END_MAP;
3921 : }
3922 :
3923 570 : accept_statement(block);
3924 570 : push_state (&s, comp, gfc_new_block);
3925 :
3926 570 : gfc_new_block->component_access = ACCESS_PUBLIC;
3927 570 : compiling_type = 1;
3928 :
3929 570 : while (compiling_type)
3930 : {
3931 1554 : st = next_statement ();
3932 1554 : switch (st)
3933 : {
3934 0 : case ST_NONE:
3935 0 : unexpected_eof ();
3936 :
3937 : /* Nested structure declarations will be captured as ST_DATA_DECL. */
3938 5 : case ST_STRUCTURE_DECL:
3939 : /* Let a more specific error make it to decode_statement(). */
3940 5 : if (gfc_error_check () == 0)
3941 0 : gfc_error ("Syntax error in nested structure declaration at %C");
3942 5 : reject_statement ();
3943 : /* Skip the rest of this statement. */
3944 5 : gfc_error_recovery ();
3945 5 : break;
3946 :
3947 132 : case ST_UNION:
3948 132 : accept_statement (ST_UNION);
3949 132 : parse_union ();
3950 132 : break;
3951 :
3952 846 : case ST_DATA_DECL:
3953 : /* The data declaration was a nested/ad-hoc STRUCTURE field. */
3954 846 : accept_statement (ST_DATA_DECL);
3955 846 : if (gfc_new_block && gfc_new_block != gfc_current_block ()
3956 21 : && gfc_new_block->attr.flavor == FL_STRUCT)
3957 21 : parse_struct_map (ST_STRUCTURE_DECL);
3958 : break;
3959 :
3960 570 : case ST_END_STRUCTURE:
3961 570 : case ST_END_MAP:
3962 570 : if (st == ends)
3963 : {
3964 570 : accept_statement (st);
3965 570 : compiling_type = 0;
3966 : }
3967 : else
3968 0 : unexpected_statement (st);
3969 : break;
3970 :
3971 1 : default:
3972 1 : unexpected_statement (st);
3973 1 : break;
3974 : }
3975 : }
3976 :
3977 : /* Validate each component. */
3978 570 : sym = gfc_current_block ();
3979 1719 : for (c = sym->components; c; c = c->next)
3980 1149 : check_component (sym, c, &lock_comp, &event_comp);
3981 :
3982 570 : sym->attr.zero_comp = (sym->components == NULL);
3983 :
3984 : /* Allow parse_union to find this structure to add to its list of maps. */
3985 570 : if (block == ST_MAP)
3986 257 : gfc_new_block = gfc_current_block ();
3987 :
3988 570 : pop_state ();
3989 570 : }
3990 :
3991 :
3992 : /* Parse a derived type. */
3993 :
3994 : static void
3995 13062 : parse_derived (void)
3996 : {
3997 13062 : int compiling_type, seen_private, seen_sequence, seen_component;
3998 13062 : gfc_statement st;
3999 13062 : gfc_state_data s;
4000 13062 : gfc_symbol *sym;
4001 13062 : gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
4002 13062 : bool pdt_parameters;
4003 :
4004 13062 : accept_statement (ST_DERIVED_DECL);
4005 13062 : push_state (&s, COMP_DERIVED, gfc_new_block);
4006 :
4007 13062 : gfc_new_block->component_access = ACCESS_PUBLIC;
4008 13062 : seen_private = 0;
4009 13062 : seen_sequence = 0;
4010 13062 : seen_component = 0;
4011 13062 : pdt_parameters = false;
4012 :
4013 13062 : compiling_type = 1;
4014 :
4015 :
4016 13062 : while (compiling_type)
4017 : {
4018 30096 : st = next_statement ();
4019 30096 : switch (st)
4020 : {
4021 0 : case ST_NONE:
4022 0 : unexpected_eof ();
4023 :
4024 16460 : case ST_DATA_DECL:
4025 16460 : case ST_PROCEDURE:
4026 16460 : accept_statement (st);
4027 16460 : seen_component = 1;
4028 : /* Type parameters must not have an explicit access specification
4029 : and must be placed before a PRIVATE statement. If a PRIVATE
4030 : statement is encountered after type parameters, mark the remaining
4031 : components as PRIVATE. */
4032 45679 : for (c = gfc_current_block ()->components; c; c = c->next)
4033 29221 : if (!c->next && (c->attr.pdt_kind || c->attr.pdt_len))
4034 : {
4035 582 : pdt_parameters = true;
4036 582 : if (c->attr.access != ACCESS_UNKNOWN)
4037 : {
4038 1 : gfc_error ("Access specification of a type parameter at "
4039 : "%C is not allowed");
4040 1 : c->attr.access = ACCESS_PUBLIC;
4041 1 : break;
4042 : }
4043 581 : if (seen_private)
4044 : {
4045 1 : gfc_error ("The type parameter at %C must come before a "
4046 : "PRIVATE statement");
4047 1 : break;
4048 : }
4049 : }
4050 28639 : else if (pdt_parameters && seen_private
4051 28 : && !(c->attr.pdt_kind || c->attr.pdt_len))
4052 8 : c->attr.access = ACCESS_PRIVATE;
4053 : break;
4054 :
4055 0 : case ST_FINAL:
4056 0 : gfc_error ("FINAL declaration at %C must be inside CONTAINS");
4057 0 : break;
4058 :
4059 13062 : case ST_END_TYPE:
4060 13062 : endType:
4061 13062 : compiling_type = 0;
4062 :
4063 13062 : if (!seen_component)
4064 1618 : gfc_notify_std (GFC_STD_F2003, "Derived type "
4065 : "definition at %C without components");
4066 :
4067 13062 : accept_statement (ST_END_TYPE);
4068 13062 : break;
4069 :
4070 333 : case ST_PRIVATE:
4071 333 : if (!gfc_find_state (COMP_MODULE))
4072 : {
4073 0 : gfc_error ("PRIVATE statement in TYPE at %C must be inside "
4074 : "a MODULE");
4075 0 : break;
4076 : }
4077 :
4078 333 : if (seen_component && !pdt_parameters)
4079 : {
4080 0 : gfc_error ("PRIVATE statement at %C must precede "
4081 : "structure components");
4082 0 : break;
4083 : }
4084 :
4085 333 : if (seen_private)
4086 0 : gfc_error ("Duplicate PRIVATE statement at %C");
4087 :
4088 333 : if (pdt_parameters)
4089 7 : s.sym->component_access = ACCESS_PUBLIC;
4090 : else
4091 326 : s.sym->component_access = ACCESS_PRIVATE;
4092 :
4093 333 : accept_statement (ST_PRIVATE);
4094 333 : seen_private = 1;
4095 333 : break;
4096 :
4097 239 : case ST_SEQUENCE:
4098 239 : if (seen_component)
4099 : {
4100 0 : gfc_error ("SEQUENCE statement at %C must precede "
4101 : "structure components");
4102 0 : break;
4103 : }
4104 :
4105 239 : if (gfc_current_block ()->attr.sequence)
4106 0 : gfc_warning (0, "SEQUENCE attribute at %C already specified in "
4107 : "TYPE statement");
4108 :
4109 239 : if (seen_sequence)
4110 : {
4111 0 : gfc_error ("Duplicate SEQUENCE statement at %C");
4112 : }
4113 :
4114 239 : seen_sequence = 1;
4115 239 : gfc_add_sequence (&gfc_current_block ()->attr,
4116 239 : gfc_current_block ()->name, NULL);
4117 239 : break;
4118 :
4119 2311 : case ST_CONTAINS:
4120 2311 : gfc_notify_std (GFC_STD_F2003,
4121 : "CONTAINS block in derived type"
4122 : " definition at %C");
4123 :
4124 2311 : accept_statement (ST_CONTAINS);
4125 2311 : parse_derived_contains ();
4126 2311 : goto endType;
4127 :
4128 2 : default:
4129 2 : unexpected_statement (st);
4130 2 : break;
4131 : }
4132 : }
4133 :
4134 : /* need to verify that all fields of the derived type are
4135 : * interoperable with C if the type is declared to be bind(c)
4136 : */
4137 13062 : sym = gfc_current_block ();
4138 32166 : for (c = sym->components; c; c = c->next)
4139 19104 : check_component (sym, c, &lock_comp, &event_comp);
4140 :
4141 13062 : if (!seen_component)
4142 1618 : sym->attr.zero_comp = 1;
4143 :
4144 13062 : pop_state ();
4145 13062 : }
4146 :
4147 :
4148 : /* Parse an ENUM. */
4149 :
4150 : static void
4151 156 : parse_enum (void)
4152 : {
4153 156 : gfc_statement st;
4154 156 : int compiling_enum;
4155 156 : gfc_state_data s;
4156 156 : int seen_enumerator = 0;
4157 :
4158 156 : push_state (&s, COMP_ENUM, gfc_new_block);
4159 :
4160 156 : compiling_enum = 1;
4161 :
4162 156 : while (compiling_enum)
4163 : {
4164 416 : st = next_statement ();
4165 416 : switch (st)
4166 : {
4167 2 : case ST_NONE:
4168 2 : unexpected_eof ();
4169 256 : break;
4170 :
4171 256 : case ST_ENUMERATOR:
4172 256 : seen_enumerator = 1;
4173 256 : accept_statement (st);
4174 256 : break;
4175 :
4176 154 : case ST_END_ENUM:
4177 154 : compiling_enum = 0;
4178 154 : if (!seen_enumerator)
4179 3 : gfc_error ("ENUM declaration at %C has no ENUMERATORS");
4180 154 : accept_statement (st);
4181 154 : break;
4182 :
4183 4 : default:
4184 4 : gfc_free_enum_history ();
4185 4 : unexpected_statement (st);
4186 4 : break;
4187 : }
4188 : }
4189 154 : pop_state ();
4190 154 : }
4191 :
4192 :
4193 : /* Parse an interface. We must be able to deal with the possibility
4194 : of recursive interfaces. The parse_spec() subroutine is mutually
4195 : recursive with parse_interface(). */
4196 :
4197 : static gfc_statement parse_spec (gfc_statement);
4198 :
4199 : static void
4200 11330 : parse_interface (void)
4201 : {
4202 11330 : gfc_compile_state new_state = COMP_NONE, current_state;
4203 11330 : gfc_symbol *prog_unit, *sym;
4204 11330 : gfc_interface_info save;
4205 11330 : gfc_state_data s1, s2;
4206 11330 : gfc_statement st;
4207 :
4208 11330 : accept_statement (ST_INTERFACE);
4209 :
4210 11330 : current_interface.ns = gfc_current_ns;
4211 11330 : save = current_interface;
4212 :
4213 4439 : sym = (current_interface.type == INTERFACE_GENERIC
4214 7047 : || current_interface.type == INTERFACE_USER_OP)
4215 11330 : ? gfc_new_block : NULL;
4216 :
4217 11330 : push_state (&s1, COMP_INTERFACE, sym);
4218 11330 : current_state = COMP_NONE;
4219 :
4220 29354 : loop:
4221 29354 : gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
4222 :
4223 29354 : st = next_statement ();
4224 29354 : switch (st)
4225 : {
4226 2 : case ST_NONE:
4227 2 : unexpected_eof ();
4228 :
4229 14865 : case ST_SUBROUTINE:
4230 14865 : case ST_FUNCTION:
4231 14865 : if (st == ST_SUBROUTINE)
4232 : new_state = COMP_SUBROUTINE;
4233 6573 : else if (st == ST_FUNCTION)
4234 6573 : new_state = COMP_FUNCTION;
4235 14865 : if (gfc_new_block->attr.pointer)
4236 : {
4237 31 : gfc_new_block->attr.pointer = 0;
4238 31 : gfc_new_block->attr.proc_pointer = 1;
4239 : }
4240 14865 : if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
4241 : gfc_new_block->formal, NULL))
4242 : {
4243 2 : reject_statement ();
4244 2 : gfc_free_namespace (gfc_current_ns);
4245 2 : goto loop;
4246 : }
4247 : /* F2008 C1210 forbids the IMPORT statement in module procedure
4248 : interface bodies and the flag is set to import symbols. */
4249 14863 : if (gfc_new_block->attr.module_procedure)
4250 518 : gfc_current_ns->has_import_set = 1;
4251 14863 : break;
4252 :
4253 3156 : case ST_PROCEDURE:
4254 3156 : case ST_MODULE_PROC: /* The module procedure matcher makes
4255 : sure the context is correct. */
4256 3156 : accept_statement (st);
4257 3156 : gfc_free_namespace (gfc_current_ns);
4258 3156 : goto loop;
4259 :
4260 11327 : case ST_END_INTERFACE:
4261 11327 : gfc_free_namespace (gfc_current_ns);
4262 11327 : gfc_current_ns = current_interface.ns;
4263 11327 : goto done;
4264 :
4265 4 : default:
4266 4 : gfc_error ("Unexpected %s statement in INTERFACE block at %C",
4267 : gfc_ascii_statement (st));
4268 4 : current_interface = save;
4269 4 : reject_statement ();
4270 4 : gfc_free_namespace (gfc_current_ns);
4271 4 : goto loop;
4272 : }
4273 :
4274 :
4275 : /* Make sure that the generic name has the right attribute. */
4276 14863 : if (current_interface.type == INTERFACE_GENERIC
4277 5561 : && current_state == COMP_NONE)
4278 : {
4279 2854 : if (new_state == COMP_FUNCTION && sym)
4280 949 : gfc_add_function (&sym->attr, sym->name, NULL);
4281 1905 : else if (new_state == COMP_SUBROUTINE && sym)
4282 1905 : gfc_add_subroutine (&sym->attr, sym->name, NULL);
4283 :
4284 : current_state = new_state;
4285 : }
4286 :
4287 14863 : if (current_interface.type == INTERFACE_ABSTRACT)
4288 : {
4289 492 : gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
4290 492 : if (gfc_is_intrinsic_typename (gfc_new_block->name))
4291 1 : gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
4292 : "cannot be the same as an intrinsic type",
4293 : gfc_new_block->name);
4294 : }
4295 :
4296 14863 : push_state (&s2, new_state, gfc_new_block);
4297 14863 : accept_statement (st);
4298 14863 : prog_unit = gfc_new_block;
4299 14863 : prog_unit->formal_ns = gfc_current_ns;
4300 :
4301 14864 : decl:
4302 : /* Read data declaration statements. */
4303 14864 : st = parse_spec (ST_NONE);
4304 14863 : in_specification_block = true;
4305 :
4306 : /* Since the interface block does not permit an IMPLICIT statement,
4307 : the default type for the function or the result must be taken
4308 : from the formal namespace. */
4309 14863 : if (new_state == COMP_FUNCTION)
4310 : {
4311 6571 : if (prog_unit->result == prog_unit
4312 5991 : && prog_unit->ts.type == BT_UNKNOWN)
4313 44 : gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
4314 6527 : else if (prog_unit->result != prog_unit
4315 580 : && prog_unit->result->ts.type == BT_UNKNOWN)
4316 11 : gfc_set_default_type (prog_unit->result, 1,
4317 11 : prog_unit->formal_ns);
4318 : }
4319 :
4320 14863 : if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
4321 : {
4322 1 : gfc_error ("Unexpected %s statement at %C in INTERFACE body",
4323 : gfc_ascii_statement (st));
4324 1 : reject_statement ();
4325 1 : goto decl;
4326 : }
4327 :
4328 : /* Add EXTERNAL attribute to function or subroutine. */
4329 14862 : if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
4330 14140 : gfc_add_external (&prog_unit->attr, &gfc_current_locus);
4331 :
4332 14862 : current_interface = save;
4333 14862 : gfc_add_interface (prog_unit);
4334 14862 : pop_state ();
4335 :
4336 14862 : if (current_interface.ns
4337 14862 : && current_interface.ns->proc_name
4338 14862 : && strcmp (current_interface.ns->proc_name->name,
4339 : prog_unit->name) == 0)
4340 1 : gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
4341 : "enclosing procedure", prog_unit->name,
4342 : ¤t_interface.ns->proc_name->declared_at);
4343 :
4344 14862 : goto loop;
4345 :
4346 11327 : done:
4347 11327 : pop_state ();
4348 11327 : }
4349 :
4350 :
4351 : /* Associate function characteristics by going back to the function
4352 : declaration and rematching the prefix. */
4353 :
4354 : static match
4355 6934 : match_deferred_characteristics (gfc_typespec * ts)
4356 : {
4357 6934 : locus loc;
4358 6934 : match m = MATCH_ERROR;
4359 6934 : char name[GFC_MAX_SYMBOL_LEN + 1];
4360 :
4361 6934 : loc = gfc_current_locus;
4362 :
4363 6934 : gfc_current_locus = gfc_current_block ()->declared_at;
4364 :
4365 6934 : gfc_clear_error ();
4366 6934 : gfc_buffer_error (true);
4367 6934 : m = gfc_match_prefix (ts);
4368 6934 : gfc_buffer_error (false);
4369 :
4370 6934 : if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
4371 : {
4372 1059 : ts->kind = 0;
4373 :
4374 1059 : if (!ts->u.derived)
4375 6934 : m = MATCH_ERROR;
4376 : }
4377 :
4378 : /* Only permit one go at the characteristic association. */
4379 6934 : if (ts->kind == -1)
4380 3 : ts->kind = 0;
4381 :
4382 : /* Set the function locus correctly. If we have not found the
4383 : function name, there is an error. */
4384 6934 : if (m == MATCH_YES
4385 6919 : && gfc_match ("function% %n", name) == MATCH_YES
4386 13851 : && strcmp (name, gfc_current_block ()->name) == 0)
4387 : {
4388 6904 : gfc_current_block ()->declared_at = gfc_current_locus;
4389 6904 : gfc_commit_symbols ();
4390 : }
4391 : else
4392 : {
4393 30 : gfc_error_check ();
4394 30 : gfc_undo_symbols ();
4395 : }
4396 :
4397 6934 : gfc_current_locus =loc;
4398 6934 : return m;
4399 : }
4400 :
4401 :
4402 : /* Check specification-expressions in the function result of the currently
4403 : parsed block and ensure they are typed (give an IMPLICIT type if necessary).
4404 : For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
4405 : scope are not yet parsed so this has to be delayed up to parse_spec. */
4406 :
4407 : static bool
4408 11397 : check_function_result_typed (void)
4409 : {
4410 11397 : gfc_typespec ts;
4411 :
4412 11397 : gcc_assert (gfc_current_state () == COMP_FUNCTION);
4413 :
4414 11397 : if (!gfc_current_ns->proc_name->result)
4415 : return true;
4416 :
4417 11397 : ts = gfc_current_ns->proc_name->result->ts;
4418 :
4419 : /* Check type-parameters, at the moment only CHARACTER lengths possible. */
4420 : /* TODO: Extend when KIND type parameters are implemented. */
4421 11397 : if (ts.type == BT_CHARACTER && ts.u.cl && ts.u.cl->length)
4422 : {
4423 : /* Reject invalid type of specification expression for length. */
4424 581 : if (ts.u.cl->length->ts.type != BT_INTEGER)
4425 : return false;
4426 :
4427 402 : gfc_expr_check_typed (ts.u.cl->length, gfc_current_ns, true);
4428 : }
4429 :
4430 : return true;
4431 : }
4432 :
4433 :
4434 : /* Parse a set of specification statements. Returns the statement
4435 : that doesn't fit. */
4436 :
4437 : static gfc_statement
4438 103458 : parse_spec (gfc_statement st)
4439 : {
4440 103458 : st_state ss;
4441 103458 : bool function_result_typed = false;
4442 103458 : bool bad_characteristic = false;
4443 103458 : gfc_typespec *ts;
4444 :
4445 103458 : in_specification_block = true;
4446 :
4447 103458 : verify_st_order (&ss, ST_NONE, false);
4448 103458 : if (st == ST_NONE)
4449 94389 : st = next_statement ();
4450 :
4451 : /* If we are not inside a function or don't have a result specified so far,
4452 : do nothing special about it. */
4453 103457 : if (gfc_current_state () != COMP_FUNCTION)
4454 : function_result_typed = true;
4455 : else
4456 : {
4457 20219 : gfc_symbol* proc = gfc_current_ns->proc_name;
4458 20219 : gcc_assert (proc);
4459 :
4460 20219 : if (proc->result && proc->result->ts.type == BT_UNKNOWN)
4461 103457 : function_result_typed = true;
4462 : }
4463 :
4464 11277 : loop:
4465 :
4466 : /* If we're inside a BLOCK construct, some statements are disallowed.
4467 : Check this here. Attribute declaration statements like INTENT, OPTIONAL
4468 : or VALUE are also disallowed, but they don't have a particular ST_*
4469 : key so we have to check for them individually in their matcher routine. */
4470 419282 : if (gfc_current_state () == COMP_BLOCK)
4471 2401 : switch (st)
4472 : {
4473 5 : case ST_IMPLICIT:
4474 5 : case ST_IMPLICIT_NONE:
4475 5 : case ST_NAMELIST:
4476 5 : case ST_COMMON:
4477 5 : case ST_EQUIVALENCE:
4478 5 : case ST_STATEMENT_FUNCTION:
4479 5 : gfc_error ("%s statement is not allowed inside of BLOCK at %C",
4480 : gfc_ascii_statement (st));
4481 5 : reject_statement ();
4482 5 : break;
4483 :
4484 : default:
4485 : break;
4486 : }
4487 416881 : else if (gfc_current_state () == COMP_BLOCK_DATA)
4488 : /* Fortran 2008, C1116. */
4489 467 : switch (st)
4490 : {
4491 : case ST_ATTR_DECL:
4492 : case ST_COMMON:
4493 : case ST_DATA:
4494 : case ST_DATA_DECL:
4495 : case ST_DERIVED_DECL:
4496 : case ST_END_BLOCK_DATA:
4497 : case ST_EQUIVALENCE:
4498 : case ST_IMPLICIT:
4499 : case ST_IMPLICIT_NONE:
4500 : case ST_OMP_ALLOCATE:
4501 : case ST_OMP_GROUPPRIVATE:
4502 : case ST_OMP_THREADPRIVATE:
4503 : case ST_PARAMETER:
4504 : case ST_STRUCTURE_DECL:
4505 : case ST_TYPE:
4506 : case ST_USE:
4507 : break;
4508 :
4509 : case ST_NONE:
4510 : break;
4511 :
4512 5 : default:
4513 5 : gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
4514 : gfc_ascii_statement (st));
4515 5 : reject_statement ();
4516 5 : break;
4517 : }
4518 :
4519 : /* If we find a statement that cannot be followed by an IMPLICIT statement
4520 : (and thus we can expect to see none any further), type the function result
4521 : if it has not yet been typed. Be careful not to give the END statement
4522 : to verify_st_order! */
4523 419282 : if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
4524 : {
4525 13264 : bool verify_now = false;
4526 :
4527 13264 : if (st == ST_END_FUNCTION || st == ST_CONTAINS)
4528 : verify_now = true;
4529 : else
4530 : {
4531 12963 : st_state dummyss;
4532 12963 : verify_st_order (&dummyss, ST_NONE, false);
4533 12963 : verify_st_order (&dummyss, st, false);
4534 :
4535 12963 : if (!verify_st_order (&dummyss, ST_IMPLICIT, true))
4536 10281 : verify_now = true;
4537 : }
4538 :
4539 12963 : if (verify_now)
4540 10582 : function_result_typed = check_function_result_typed ();
4541 : }
4542 :
4543 419282 : switch (st)
4544 : {
4545 12 : case ST_NONE:
4546 12 : unexpected_eof ();
4547 :
4548 24501 : case ST_IMPLICIT_NONE:
4549 24501 : case ST_IMPLICIT:
4550 24501 : if (!function_result_typed)
4551 815 : function_result_typed = check_function_result_typed ();
4552 24501 : goto declSt;
4553 :
4554 2831 : case ST_FORMAT:
4555 2831 : case ST_ENTRY:
4556 2831 : case ST_DATA: /* Not allowed in interfaces */
4557 2831 : if (gfc_current_state () == COMP_INTERFACE)
4558 : break;
4559 :
4560 : /* Fall through */
4561 :
4562 308657 : case ST_USE:
4563 308657 : case ST_IMPORT:
4564 308657 : case ST_PARAMETER:
4565 308657 : case ST_PUBLIC:
4566 308657 : case ST_PRIVATE:
4567 308657 : case ST_STRUCTURE_DECL:
4568 308657 : case ST_DERIVED_DECL:
4569 308657 : case_decl:
4570 308657 : case_omp_decl:
4571 2831 : declSt:
4572 308657 : if (!verify_st_order (&ss, st, false))
4573 : {
4574 1 : reject_statement ();
4575 1 : st = next_statement ();
4576 1 : goto loop;
4577 : }
4578 :
4579 308656 : switch (st)
4580 : {
4581 11330 : case ST_INTERFACE:
4582 11330 : parse_interface ();
4583 11330 : break;
4584 :
4585 292 : case ST_STRUCTURE_DECL:
4586 292 : parse_struct_map (ST_STRUCTURE_DECL);
4587 292 : break;
4588 :
4589 13062 : case ST_DERIVED_DECL:
4590 13062 : parse_derived ();
4591 13062 : break;
4592 :
4593 1023 : case ST_PUBLIC:
4594 1023 : case ST_PRIVATE:
4595 1023 : if (gfc_current_state () != COMP_MODULE)
4596 : {
4597 0 : gfc_error ("%s statement must appear in a MODULE",
4598 : gfc_ascii_statement (st));
4599 0 : reject_statement ();
4600 0 : break;
4601 : }
4602 :
4603 1023 : if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
4604 : {
4605 0 : gfc_error ("%s statement at %C follows another accessibility "
4606 : "specification", gfc_ascii_statement (st));
4607 0 : reject_statement ();
4608 0 : break;
4609 : }
4610 :
4611 2046 : gfc_current_ns->default_access = (st == ST_PUBLIC)
4612 1023 : ? ACCESS_PUBLIC : ACCESS_PRIVATE;
4613 :
4614 1023 : break;
4615 :
4616 227 : case ST_STATEMENT_FUNCTION:
4617 227 : if (gfc_current_state () == COMP_MODULE
4618 227 : || gfc_current_state () == COMP_SUBMODULE)
4619 : {
4620 1 : unexpected_statement (st);
4621 1 : break;
4622 : }
4623 :
4624 : default:
4625 : break;
4626 : }
4627 :
4628 308653 : accept_statement (st);
4629 308653 : st = next_statement ();
4630 308649 : goto loop;
4631 :
4632 87 : case ST_GENERIC:
4633 87 : accept_statement (st);
4634 87 : st = next_statement ();
4635 87 : goto loop;
4636 :
4637 156 : case ST_ENUM:
4638 156 : accept_statement (st);
4639 156 : parse_enum();
4640 154 : st = next_statement ();
4641 154 : goto loop;
4642 :
4643 6934 : case ST_GET_FCN_CHARACTERISTICS:
4644 : /* This statement triggers the association of a function's result
4645 : characteristics. */
4646 6934 : ts = &gfc_current_block ()->result->ts;
4647 6934 : if (match_deferred_characteristics (ts) != MATCH_YES)
4648 15 : bad_characteristic = true;
4649 :
4650 6934 : st = next_statement ();
4651 6934 : goto loop;
4652 :
4653 : default:
4654 : break;
4655 : }
4656 :
4657 : /* If match_deferred_characteristics failed, then there is an error. */
4658 103436 : if (bad_characteristic)
4659 : {
4660 15 : ts = &gfc_current_block ()->result->ts;
4661 15 : if (ts->type != BT_DERIVED && ts->type != BT_CLASS)
4662 5 : gfc_error ("Bad kind expression for function %qs at %L",
4663 : gfc_current_block ()->name,
4664 : &gfc_current_block ()->declared_at);
4665 : else
4666 10 : gfc_error ("The type for function %qs at %L is not accessible",
4667 : gfc_current_block ()->name,
4668 : &gfc_current_block ()->declared_at);
4669 :
4670 15 : gfc_current_block ()->ts.kind = 0;
4671 : /* Keep the derived type; if it's bad, it will be discovered later. */
4672 15 : if (!(ts->type == BT_DERIVED && ts->u.derived))
4673 15 : ts->type = BT_UNKNOWN;
4674 : }
4675 :
4676 103436 : in_specification_block = false;
4677 :
4678 103436 : return st;
4679 : }
4680 :
4681 :
4682 : /* Parse a WHERE block, (not a simple WHERE statement). */
4683 :
4684 : static void
4685 371 : parse_where_block (void)
4686 : {
4687 371 : int seen_empty_else;
4688 371 : gfc_code *top, *d;
4689 371 : gfc_state_data s;
4690 371 : gfc_statement st;
4691 :
4692 371 : accept_statement (ST_WHERE_BLOCK);
4693 371 : top = gfc_state_stack->tail;
4694 :
4695 371 : push_state (&s, COMP_WHERE, gfc_new_block);
4696 :
4697 371 : d = add_statement ();
4698 371 : d->expr1 = top->expr1;
4699 371 : d->op = EXEC_WHERE;
4700 :
4701 371 : top->expr1 = NULL;
4702 371 : top->block = d;
4703 :
4704 371 : seen_empty_else = 0;
4705 :
4706 1342 : do
4707 : {
4708 1342 : st = next_statement ();
4709 1342 : switch (st)
4710 : {
4711 0 : case ST_NONE:
4712 0 : unexpected_eof ();
4713 :
4714 40 : case ST_WHERE_BLOCK:
4715 40 : parse_where_block ();
4716 40 : break;
4717 :
4718 619 : case ST_ASSIGNMENT:
4719 619 : case ST_WHERE:
4720 619 : accept_statement (st);
4721 619 : break;
4722 :
4723 312 : case ST_ELSEWHERE:
4724 312 : if (seen_empty_else)
4725 : {
4726 1 : gfc_error ("ELSEWHERE statement at %C follows previous "
4727 : "unmasked ELSEWHERE");
4728 1 : reject_statement ();
4729 1 : break;
4730 : }
4731 :
4732 311 : if (new_st.expr1 == NULL)
4733 133 : seen_empty_else = 1;
4734 :
4735 311 : d = new_level (gfc_state_stack->head);
4736 311 : d->op = EXEC_WHERE;
4737 311 : d->expr1 = new_st.expr1;
4738 :
4739 311 : accept_statement (st);
4740 :
4741 311 : break;
4742 :
4743 371 : case ST_END_WHERE:
4744 371 : accept_statement (st);
4745 371 : break;
4746 :
4747 0 : default:
4748 0 : gfc_error ("Unexpected %s statement in WHERE block at %C",
4749 : gfc_ascii_statement (st));
4750 0 : reject_statement ();
4751 0 : break;
4752 : }
4753 : }
4754 1342 : while (st != ST_END_WHERE);
4755 :
4756 371 : pop_state ();
4757 371 : }
4758 :
4759 :
4760 : /* Parse a FORALL block (not a simple FORALL statement). */
4761 :
4762 : static void
4763 507 : parse_forall_block (void)
4764 : {
4765 507 : gfc_code *top, *d;
4766 507 : gfc_state_data s;
4767 507 : gfc_statement st;
4768 :
4769 507 : accept_statement (ST_FORALL_BLOCK);
4770 507 : top = gfc_state_stack->tail;
4771 :
4772 507 : push_state (&s, COMP_FORALL, gfc_new_block);
4773 :
4774 507 : d = add_statement ();
4775 507 : d->op = EXEC_FORALL;
4776 507 : top->block = d;
4777 :
4778 1026 : do
4779 : {
4780 1026 : st = next_statement ();
4781 1026 : switch (st)
4782 : {
4783 :
4784 395 : case ST_ASSIGNMENT:
4785 395 : case ST_POINTER_ASSIGNMENT:
4786 395 : case ST_WHERE:
4787 395 : case ST_FORALL:
4788 395 : accept_statement (st);
4789 395 : break;
4790 :
4791 46 : case ST_WHERE_BLOCK:
4792 46 : parse_where_block ();
4793 46 : break;
4794 :
4795 78 : case ST_FORALL_BLOCK:
4796 78 : parse_forall_block ();
4797 78 : break;
4798 :
4799 507 : case ST_END_FORALL:
4800 507 : accept_statement (st);
4801 507 : break;
4802 :
4803 0 : case ST_NONE:
4804 0 : unexpected_eof ();
4805 :
4806 0 : default:
4807 0 : gfc_error ("Unexpected %s statement in FORALL block at %C",
4808 : gfc_ascii_statement (st));
4809 :
4810 0 : reject_statement ();
4811 0 : break;
4812 : }
4813 : }
4814 1026 : while (st != ST_END_FORALL);
4815 :
4816 507 : pop_state ();
4817 507 : }
4818 :
4819 :
4820 : static gfc_statement parse_executable (gfc_statement);
4821 :
4822 : /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
4823 :
4824 : static void
4825 14938 : parse_if_block (void)
4826 : {
4827 14938 : gfc_code *top, *d;
4828 14938 : gfc_statement st;
4829 14938 : locus else_locus;
4830 14938 : gfc_state_data s;
4831 14938 : int seen_else;
4832 :
4833 14938 : seen_else = 0;
4834 14938 : accept_statement (ST_IF_BLOCK);
4835 :
4836 14938 : top = gfc_state_stack->tail;
4837 14938 : push_state (&s, COMP_IF, gfc_new_block);
4838 :
4839 14938 : new_st.op = EXEC_IF;
4840 14938 : d = add_statement ();
4841 :
4842 14938 : d->expr1 = top->expr1;
4843 14938 : top->expr1 = NULL;
4844 14938 : top->block = d;
4845 :
4846 21002 : do
4847 : {
4848 21002 : st = parse_executable (ST_NONE);
4849 :
4850 21001 : switch (st)
4851 : {
4852 0 : case ST_NONE:
4853 0 : unexpected_eof ();
4854 :
4855 1937 : case ST_ELSEIF:
4856 1937 : if (seen_else)
4857 : {
4858 0 : gfc_error ("ELSE IF statement at %C cannot follow ELSE "
4859 : "statement at %L", &else_locus);
4860 :
4861 0 : reject_statement ();
4862 0 : break;
4863 : }
4864 :
4865 1937 : d = new_level (gfc_state_stack->head);
4866 1937 : d->op = EXEC_IF;
4867 1937 : d->expr1 = new_st.expr1;
4868 :
4869 1937 : accept_statement (st);
4870 :
4871 1937 : break;
4872 :
4873 4124 : case ST_ELSE:
4874 4124 : if (seen_else)
4875 : {
4876 0 : gfc_error ("Duplicate ELSE statements at %L and %C",
4877 : &else_locus);
4878 0 : reject_statement ();
4879 0 : break;
4880 : }
4881 :
4882 4124 : seen_else = 1;
4883 4124 : else_locus = gfc_current_locus;
4884 :
4885 4124 : d = new_level (gfc_state_stack->head);
4886 4124 : d->op = EXEC_IF;
4887 :
4888 4124 : accept_statement (st);
4889 :
4890 4124 : break;
4891 :
4892 : case ST_ENDIF:
4893 : break;
4894 :
4895 3 : default:
4896 3 : unexpected_statement (st);
4897 3 : break;
4898 : }
4899 : }
4900 21001 : while (st != ST_ENDIF);
4901 :
4902 14937 : pop_state ();
4903 14937 : accept_statement (st);
4904 14937 : }
4905 :
4906 :
4907 : /* Parse a SELECT block. */
4908 :
4909 : static void
4910 533 : parse_select_block (void)
4911 : {
4912 533 : gfc_statement st;
4913 533 : gfc_code *cp;
4914 533 : gfc_state_data s;
4915 :
4916 533 : accept_statement (ST_SELECT_CASE);
4917 :
4918 533 : cp = gfc_state_stack->tail;
4919 533 : push_state (&s, COMP_SELECT, gfc_new_block);
4920 :
4921 : /* Make sure that the next statement is a CASE or END SELECT. */
4922 535 : for (;;)
4923 : {
4924 534 : st = next_statement ();
4925 534 : if (st == ST_NONE)
4926 0 : unexpected_eof ();
4927 534 : if (st == ST_END_SELECT)
4928 : {
4929 : /* Empty SELECT CASE is OK. */
4930 14 : accept_statement (st);
4931 14 : pop_state ();
4932 14 : return;
4933 : }
4934 520 : if (st == ST_CASE)
4935 : break;
4936 :
4937 1 : gfc_error ("Expected a CASE or END SELECT statement following SELECT "
4938 : "CASE at %C");
4939 :
4940 1 : reject_statement ();
4941 : }
4942 :
4943 : /* At this point, we've got a nonempty select block. */
4944 519 : cp = new_level (cp);
4945 519 : *cp = new_st;
4946 :
4947 519 : accept_statement (st);
4948 :
4949 1591 : do
4950 : {
4951 1591 : st = parse_executable (ST_NONE);
4952 1591 : switch (st)
4953 : {
4954 0 : case ST_NONE:
4955 0 : unexpected_eof ();
4956 :
4957 1072 : case ST_CASE:
4958 1072 : cp = new_level (gfc_state_stack->head);
4959 1072 : *cp = new_st;
4960 1072 : gfc_clear_new_st ();
4961 :
4962 1072 : accept_statement (st);
4963 : /* Fall through */
4964 :
4965 : case ST_END_SELECT:
4966 : break;
4967 :
4968 : /* Can't have an executable statement because of
4969 : parse_executable(). */
4970 0 : default:
4971 0 : unexpected_statement (st);
4972 0 : break;
4973 : }
4974 : }
4975 1591 : while (st != ST_END_SELECT);
4976 :
4977 519 : pop_state ();
4978 519 : accept_statement (st);
4979 : }
4980 :
4981 :
4982 : /* Pop the current selector from the SELECT TYPE stack. */
4983 :
4984 : static void
4985 4117 : select_type_pop (void)
4986 : {
4987 4117 : gfc_select_type_stack *old = select_type_stack;
4988 4117 : select_type_stack = old->prev;
4989 4117 : free (old);
4990 4117 : }
4991 :
4992 :
4993 : /* Parse a SELECT TYPE construct (F03:R821). */
4994 :
4995 : static void
4996 3083 : parse_select_type_block (void)
4997 : {
4998 3083 : gfc_statement st;
4999 3083 : gfc_code *cp;
5000 3083 : gfc_state_data s;
5001 :
5002 3083 : gfc_current_ns = new_st.ext.block.ns;
5003 3083 : accept_statement (ST_SELECT_TYPE);
5004 :
5005 3083 : cp = gfc_state_stack->tail;
5006 3083 : push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
5007 :
5008 : /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
5009 : or END SELECT. */
5010 3093 : for (;;)
5011 : {
5012 3088 : st = next_statement ();
5013 3088 : if (st == ST_NONE)
5014 2 : unexpected_eof ();
5015 3086 : if (st == ST_END_SELECT)
5016 : /* Empty SELECT CASE is OK. */
5017 23 : goto done;
5018 3063 : if (st == ST_TYPE_IS || st == ST_CLASS_IS)
5019 : break;
5020 :
5021 5 : gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
5022 : "following SELECT TYPE at %C");
5023 :
5024 5 : reject_statement ();
5025 : }
5026 :
5027 : /* At this point, we've got a nonempty select block. */
5028 3058 : cp = new_level (cp);
5029 3058 : *cp = new_st;
5030 :
5031 3058 : accept_statement (st);
5032 :
5033 5471 : do
5034 : {
5035 5471 : st = parse_executable (ST_NONE);
5036 5471 : switch (st)
5037 : {
5038 0 : case ST_NONE:
5039 0 : unexpected_eof ();
5040 :
5041 2413 : case ST_TYPE_IS:
5042 2413 : case ST_CLASS_IS:
5043 2413 : cp = new_level (gfc_state_stack->head);
5044 2413 : *cp = new_st;
5045 2413 : gfc_clear_new_st ();
5046 :
5047 2413 : accept_statement (st);
5048 : /* Fall through */
5049 :
5050 : case ST_END_SELECT:
5051 : break;
5052 :
5053 : /* Can't have an executable statement because of
5054 : parse_executable(). */
5055 0 : default:
5056 0 : unexpected_statement (st);
5057 0 : break;
5058 : }
5059 : }
5060 5471 : while (st != ST_END_SELECT);
5061 :
5062 3058 : done:
5063 3081 : pop_state ();
5064 3081 : accept_statement (st);
5065 3081 : gfc_current_ns = gfc_current_ns->parent;
5066 3081 : select_type_pop ();
5067 3081 : }
5068 :
5069 :
5070 : /* Parse a SELECT RANK construct. */
5071 :
5072 : static void
5073 1036 : parse_select_rank_block (void)
5074 : {
5075 1036 : gfc_statement st;
5076 1036 : gfc_code *cp;
5077 1036 : gfc_state_data s;
5078 :
5079 1036 : gfc_current_ns = new_st.ext.block.ns;
5080 1036 : accept_statement (ST_SELECT_RANK);
5081 :
5082 1036 : cp = gfc_state_stack->tail;
5083 1036 : push_state (&s, COMP_SELECT_RANK, gfc_new_block);
5084 :
5085 : /* Make sure that the next statement is a RANK IS or RANK DEFAULT. */
5086 1042 : for (;;)
5087 : {
5088 1039 : st = next_statement ();
5089 1039 : if (st == ST_NONE)
5090 0 : unexpected_eof ();
5091 1039 : if (st == ST_END_SELECT)
5092 : /* Empty SELECT CASE is OK. */
5093 3 : goto done;
5094 1036 : if (st == ST_RANK)
5095 : break;
5096 :
5097 3 : gfc_error ("Expected RANK or RANK DEFAULT "
5098 : "following SELECT RANK at %C");
5099 :
5100 3 : reject_statement ();
5101 : }
5102 :
5103 : /* At this point, we've got a nonempty select block. */
5104 1033 : cp = new_level (cp);
5105 1033 : *cp = new_st;
5106 :
5107 1033 : accept_statement (st);
5108 :
5109 2344 : do
5110 : {
5111 2344 : st = parse_executable (ST_NONE);
5112 2344 : switch (st)
5113 : {
5114 0 : case ST_NONE:
5115 0 : unexpected_eof ();
5116 :
5117 1311 : case ST_RANK:
5118 1311 : cp = new_level (gfc_state_stack->head);
5119 1311 : *cp = new_st;
5120 1311 : gfc_clear_new_st ();
5121 :
5122 1311 : accept_statement (st);
5123 : /* Fall through */
5124 :
5125 : case ST_END_SELECT:
5126 : break;
5127 :
5128 : /* Can't have an executable statement because of
5129 : parse_executable(). */
5130 0 : default:
5131 0 : unexpected_statement (st);
5132 0 : break;
5133 : }
5134 : }
5135 2344 : while (st != ST_END_SELECT);
5136 :
5137 1033 : done:
5138 1036 : pop_state ();
5139 1036 : accept_statement (st);
5140 1036 : gfc_current_ns = gfc_current_ns->parent;
5141 1036 : select_type_pop ();
5142 1036 : }
5143 :
5144 :
5145 : /* Given a symbol, make sure it is not an iteration variable for a DO
5146 : statement. This subroutine is called when the symbol is seen in a
5147 : context that causes it to become redefined. If the symbol is an
5148 : iterator, we generate an error message and return nonzero. */
5149 :
5150 : bool
5151 358475 : gfc_check_do_variable (gfc_symtree *st)
5152 : {
5153 358475 : gfc_state_data *s;
5154 :
5155 358475 : if (!st)
5156 : return 0;
5157 :
5158 1595937 : for (s=gfc_state_stack; s; s = s->previous)
5159 1237475 : if (s->do_variable == st)
5160 : {
5161 8 : gfc_error_now ("Variable %qs at %C cannot be redefined inside "
5162 8 : "loop beginning at %L", st->name, &s->head->loc);
5163 8 : return 1;
5164 : }
5165 :
5166 : return 0;
5167 : }
5168 :
5169 :
5170 : /* Checks to see if the current statement label closes an enddo.
5171 : Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
5172 : an error) if it incorrectly closes an ENDDO. */
5173 :
5174 : static int
5175 931936 : check_do_closure (void)
5176 : {
5177 931936 : gfc_state_data *p;
5178 :
5179 931936 : if (gfc_statement_label == NULL)
5180 : return 0;
5181 :
5182 16018 : for (p = gfc_state_stack; p; p = p->previous)
5183 12369 : if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
5184 : break;
5185 :
5186 6713 : if (p == NULL)
5187 : return 0; /* No loops to close */
5188 :
5189 3064 : if (p->ext.end_do_label == gfc_statement_label)
5190 : {
5191 2257 : if (p == gfc_state_stack)
5192 : return 1;
5193 :
5194 1 : gfc_error ("End of nonblock DO statement at %C is within another block");
5195 1 : return 2;
5196 : }
5197 :
5198 : /* At this point, the label doesn't terminate the innermost loop.
5199 : Make sure it doesn't terminate another one. */
5200 4568 : for (; p; p = p->previous)
5201 3761 : if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
5202 1057 : && p->ext.end_do_label == gfc_statement_label)
5203 : {
5204 0 : gfc_error ("End of nonblock DO statement at %C is interwoven "
5205 : "with another DO loop");
5206 0 : return 2;
5207 : }
5208 :
5209 : return 0;
5210 : }
5211 :
5212 :
5213 : /* Parse a series of contained program units. */
5214 :
5215 : static void parse_progunit (gfc_statement);
5216 :
5217 :
5218 : /* Parse a CRITICAL block. */
5219 :
5220 : static void
5221 54 : parse_critical_block (void)
5222 : {
5223 54 : gfc_code *top, *d;
5224 54 : gfc_state_data s, *sd;
5225 54 : gfc_statement st;
5226 :
5227 185 : for (sd = gfc_state_stack; sd; sd = sd->previous)
5228 131 : if (sd->state == COMP_OMP_STRUCTURED_BLOCK)
5229 4 : gfc_error_now (is_oacc (sd)
5230 : ? G_("CRITICAL block inside of OpenACC region at %C")
5231 : : G_("CRITICAL block inside of OpenMP region at %C"));
5232 :
5233 54 : s.ext.end_do_label = new_st.label1;
5234 :
5235 54 : accept_statement (ST_CRITICAL);
5236 54 : top = gfc_state_stack->tail;
5237 :
5238 54 : push_state (&s, COMP_CRITICAL, gfc_new_block);
5239 :
5240 54 : d = add_statement ();
5241 54 : d->op = EXEC_CRITICAL;
5242 54 : top->block = d;
5243 :
5244 54 : do
5245 : {
5246 54 : st = parse_executable (ST_NONE);
5247 :
5248 54 : switch (st)
5249 : {
5250 0 : case ST_NONE:
5251 0 : unexpected_eof ();
5252 54 : break;
5253 :
5254 54 : case ST_END_CRITICAL:
5255 54 : if (s.ext.end_do_label != NULL
5256 0 : && s.ext.end_do_label != gfc_statement_label)
5257 0 : gfc_error_now ("Statement label in END CRITICAL at %C does not "
5258 : "match CRITICAL label");
5259 :
5260 54 : if (gfc_statement_label != NULL)
5261 : {
5262 1 : new_st.op = EXEC_NOP;
5263 1 : add_statement ();
5264 : }
5265 : break;
5266 :
5267 0 : default:
5268 0 : unexpected_statement (st);
5269 0 : break;
5270 : }
5271 : }
5272 54 : while (st != ST_END_CRITICAL);
5273 :
5274 54 : pop_state ();
5275 54 : accept_statement (st);
5276 54 : }
5277 :
5278 :
5279 : /* Set up the local namespace for a BLOCK construct. */
5280 :
5281 : gfc_namespace*
5282 15010 : gfc_build_block_ns (gfc_namespace *parent_ns)
5283 : {
5284 15010 : gfc_namespace* my_ns;
5285 15010 : static int numblock = 1;
5286 :
5287 15010 : my_ns = gfc_get_namespace (parent_ns, 1);
5288 15010 : my_ns->construct_entities = 1;
5289 :
5290 : /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
5291 : code generation (so it must not be NULL).
5292 : We set its recursive argument if our container procedure is recursive, so
5293 : that local variables are accordingly placed on the stack when it
5294 : will be necessary. */
5295 15010 : if (gfc_new_block)
5296 142 : my_ns->proc_name = gfc_new_block;
5297 : else
5298 : {
5299 14868 : bool t;
5300 14868 : char buffer[20]; /* Enough to hold "block@2147483648\n". */
5301 :
5302 14868 : snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
5303 14868 : gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
5304 29736 : t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
5305 14868 : my_ns->proc_name->name, NULL);
5306 14868 : gcc_assert (t);
5307 14868 : gfc_commit_symbol (my_ns->proc_name);
5308 : }
5309 :
5310 15010 : if (parent_ns->proc_name)
5311 15007 : my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
5312 :
5313 15010 : return my_ns;
5314 : }
5315 :
5316 :
5317 : /* Parse a BLOCK construct. */
5318 :
5319 : static void
5320 1080 : parse_block_construct (void)
5321 : {
5322 1080 : gfc_namespace* my_ns;
5323 1080 : gfc_namespace* my_parent;
5324 1080 : gfc_state_data s;
5325 :
5326 1080 : gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
5327 :
5328 1080 : my_ns = gfc_build_block_ns (gfc_current_ns);
5329 :
5330 1080 : new_st.op = EXEC_BLOCK;
5331 1080 : new_st.ext.block.ns = my_ns;
5332 1080 : new_st.ext.block.assoc = NULL;
5333 1080 : accept_statement (ST_BLOCK);
5334 :
5335 1080 : push_state (&s, COMP_BLOCK, my_ns->proc_name);
5336 1080 : gfc_current_ns = my_ns;
5337 1080 : my_parent = my_ns->parent;
5338 :
5339 1080 : parse_progunit (ST_NONE);
5340 :
5341 : /* Don't depend on the value of gfc_current_ns; it might have been
5342 : reset if the block had errors and was cleaned up. */
5343 1071 : gfc_current_ns = my_parent;
5344 :
5345 1071 : pop_state ();
5346 1071 : }
5347 :
5348 : static void
5349 1551 : move_associates_to_block ()
5350 : {
5351 1551 : gfc_association_list *a;
5352 1551 : gfc_array_spec *as;
5353 :
5354 3238 : for (a = new_st.ext.block.assoc; a; a = a->next)
5355 : {
5356 1687 : gfc_symbol *sym, *tsym;
5357 1687 : gfc_expr *target;
5358 1687 : int rank, corank;
5359 :
5360 1687 : if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
5361 0 : gcc_unreachable ();
5362 :
5363 1687 : sym = a->st->n.sym;
5364 1687 : sym->attr.flavor = FL_VARIABLE;
5365 1687 : sym->assoc = a;
5366 1687 : sym->declared_at = a->where;
5367 1687 : gfc_set_sym_referenced (sym);
5368 :
5369 : /* If the selector is a inferred type then the associate_name had better
5370 : be as well. Use array references, if present, to identify it as an
5371 : array. */
5372 1687 : if (IS_INFERRED_TYPE (a->target))
5373 : {
5374 18 : sym->assoc->inferred_type = 1;
5375 48 : for (gfc_ref *r = a->target->ref; r; r = r->next)
5376 30 : if (r->type == REF_ARRAY)
5377 18 : sym->attr.dimension = 1;
5378 : }
5379 :
5380 : /* Initialize the typespec. It is not available in all cases,
5381 : however, as it may only be set on the target during resolution.
5382 : Still, sometimes it helps to have it right now -- especially
5383 : for parsing component references on the associate-name
5384 : in case of association to a derived-type. */
5385 1687 : sym->ts = a->target->ts;
5386 1687 : target = a->target;
5387 :
5388 : /* Don’t share the character length information between associate
5389 : variable and target if the length is not a compile-time constant,
5390 : as we don’t want to touch some other character length variable
5391 : when we try to initialize the associate variable’s character
5392 : length variable. We do it here rather than later so that expressions
5393 : referencing the associate variable will automatically have the
5394 : correctly setup length information. If we did it at resolution stage
5395 : the expressions would use the original length information, and the
5396 : variable a new different one, but only the latter one would be
5397 : correctly initialized at translation stage, and the former one would
5398 : need some additional setup there. */
5399 1687 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
5400 204 : && !(sym->ts.u.cl->length
5401 92 : && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT))
5402 124 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5403 :
5404 : /* If the function has been parsed, go straight to the result to
5405 : obtain the expression rank. */
5406 1687 : if (target->expr_type == EXPR_FUNCTION && target->symtree
5407 440 : && target->symtree->n.sym)
5408 : {
5409 440 : tsym = target->symtree->n.sym;
5410 440 : if (!tsym->result)
5411 0 : tsym->result = tsym;
5412 440 : sym->ts = tsym->result->ts;
5413 440 : if (sym->ts.type == BT_CLASS)
5414 : {
5415 18 : if (CLASS_DATA (sym)->as)
5416 : {
5417 12 : target->rank = CLASS_DATA (sym)->as->rank;
5418 12 : target->corank = CLASS_DATA (sym)->as->corank;
5419 : }
5420 18 : sym->attr.class_ok = 1;
5421 : }
5422 : else
5423 : {
5424 422 : target->rank = tsym->result->as ? tsym->result->as->rank : 0;
5425 422 : target->corank = tsym->result->as ? tsym->result->as->corank : 0;
5426 : }
5427 : }
5428 :
5429 : /* Check if the target expression is array valued. This cannot be done
5430 : by calling gfc_resolve_expr because the context is unavailable.
5431 : However, the references can be resolved and the rank of the target
5432 : expression set. */
5433 1669 : if (!sym->assoc->inferred_type && target->ref && gfc_resolve_ref (target)
5434 621 : && target->expr_type != EXPR_ARRAY
5435 2308 : && target->expr_type != EXPR_COMPCALL)
5436 620 : gfc_expression_rank (target);
5437 :
5438 : /* Determine whether or not function expressions with unknown type are
5439 : structure constructors. If so, the function result can be converted
5440 : to be a derived type. */
5441 1687 : if (target->expr_type == EXPR_FUNCTION && target->ts.type == BT_UNKNOWN)
5442 : {
5443 402 : gfc_symbol *derived;
5444 : /* The derived type has a leading uppercase character. */
5445 402 : gfc_find_symbol (gfc_dt_upper_string (target->symtree->name),
5446 402 : gfc_current_ns->parent, 1, &derived);
5447 402 : if (derived && derived->attr.flavor == FL_DERIVED)
5448 : {
5449 34 : sym->ts.type = BT_DERIVED;
5450 34 : sym->ts.u.derived = derived;
5451 34 : sym->assoc->inferred_type = 0;
5452 : }
5453 : }
5454 :
5455 1687 : rank = target->rank;
5456 1687 : corank = target->corank;
5457 : /* Fixup cases where the ranks are mismatched. */
5458 1687 : if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
5459 : {
5460 164 : if ((!CLASS_DATA (sym)->as && (rank != 0 || corank != 0))
5461 164 : || (CLASS_DATA (sym)->as
5462 103 : && (CLASS_DATA (sym)->as->rank != rank
5463 77 : || CLASS_DATA (sym)->as->corank != corank))
5464 138 : || rank == -1)
5465 : {
5466 : /* Don't just (re-)set the attr and as in the sym.ts,
5467 : because this modifies the target's attr and as. Copy the
5468 : data and do a build_class_symbol. */
5469 38 : symbol_attribute attr = CLASS_DATA (target)->attr;
5470 38 : gfc_typespec type;
5471 38 : if (rank == -1 && a->ar)
5472 : {
5473 12 : as = gfc_get_array_spec ();
5474 12 : as->rank = a->ar->dimen;
5475 12 : as->corank = 0;
5476 12 : as->type = AS_DEFERRED;
5477 12 : attr.dimension = rank ? 1 : 0;
5478 12 : attr.codimension = as->corank ? 1 : 0;
5479 12 : sym->assoc->variable = true;
5480 : }
5481 26 : else if (rank || corank)
5482 : {
5483 0 : as = gfc_get_array_spec ();
5484 0 : as->type = AS_DEFERRED;
5485 0 : as->rank = rank;
5486 0 : as->corank = corank;
5487 0 : attr.dimension = rank ? 1 : 0;
5488 0 : attr.codimension = corank ? 1 : 0;
5489 : }
5490 : else
5491 : {
5492 26 : as = NULL;
5493 26 : attr.dimension = attr.codimension = 0;
5494 : }
5495 38 : attr.class_ok = 0;
5496 38 : attr.associate_var = 1;
5497 38 : type = CLASS_DATA (sym)->ts;
5498 38 : if (!gfc_build_class_symbol (&type, &attr, &as))
5499 0 : gcc_unreachable ();
5500 38 : sym->ts = type;
5501 38 : sym->ts.type = BT_CLASS;
5502 38 : sym->attr.class_ok = 1;
5503 38 : }
5504 : else
5505 126 : sym->attr.class_ok = 1;
5506 : }
5507 1523 : else if (rank == -1 && a->ar)
5508 : {
5509 14 : sym->as = gfc_get_array_spec ();
5510 14 : sym->as->rank = a->ar->dimen;
5511 14 : sym->as->corank = a->ar->codimen;
5512 14 : sym->as->type = AS_DEFERRED;
5513 14 : sym->attr.dimension = 1;
5514 14 : sym->attr.codimension = sym->as->corank ? 1 : 0;
5515 14 : sym->attr.pointer = 1;
5516 : }
5517 1509 : else if ((!sym->as && (rank != 0 || corank != 0))
5518 988 : || (sym->as
5519 0 : && (sym->as->rank != rank || sym->as->corank != corank)))
5520 : {
5521 521 : as = gfc_get_array_spec ();
5522 521 : as->type = AS_DEFERRED;
5523 521 : as->rank = rank;
5524 521 : as->corank = corank;
5525 521 : sym->as = as;
5526 521 : if (rank)
5527 505 : sym->attr.dimension = 1;
5528 521 : if (corank)
5529 : {
5530 18 : as->cotype = AS_ASSUMED_SHAPE;
5531 18 : sym->attr.codimension = 1;
5532 : }
5533 : }
5534 1687 : gfc_commit_symbols ();
5535 : }
5536 1551 : }
5537 :
5538 : /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
5539 : behind the scenes with compiler-generated variables. */
5540 :
5541 : static void
5542 1548 : parse_associate (void)
5543 : {
5544 1548 : gfc_namespace* my_ns;
5545 1548 : gfc_state_data s;
5546 1548 : gfc_statement st;
5547 :
5548 1548 : gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
5549 :
5550 1548 : my_ns = gfc_build_block_ns (gfc_current_ns);
5551 :
5552 1548 : new_st.op = EXEC_BLOCK;
5553 1548 : new_st.ext.block.ns = my_ns;
5554 1548 : gcc_assert (new_st.ext.block.assoc);
5555 :
5556 : /* Add all associate-names as BLOCK variables. Creating them is enough
5557 : for now, they'll get their values during trans-* phase. */
5558 1548 : gfc_current_ns = my_ns;
5559 1548 : move_associates_to_block ();
5560 :
5561 1548 : accept_statement (ST_ASSOCIATE);
5562 1548 : push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
5563 :
5564 1550 : loop:
5565 1550 : st = parse_executable (ST_NONE);
5566 1547 : switch (st)
5567 : {
5568 0 : case ST_NONE:
5569 0 : unexpected_eof ();
5570 :
5571 1545 : case_end:
5572 1545 : accept_statement (st);
5573 1545 : my_ns->code = gfc_state_stack->head;
5574 1545 : break;
5575 :
5576 2 : default:
5577 2 : unexpected_statement (st);
5578 2 : goto loop;
5579 : }
5580 :
5581 1545 : gfc_current_ns = gfc_current_ns->parent;
5582 1545 : pop_state ();
5583 1545 : }
5584 :
5585 :
5586 : /* F2018(11.1.5.2): Track coarrays allocated within CHANGE TEAM blocks.
5587 : Map from team namespace to vector of allocated coarray symbols. */
5588 : hash_map<gfc_namespace *, vec<gfc_expr *>> team_allocated_coarrays;
5589 :
5590 : /* Stack to track current CHANGE TEAM context. */
5591 : vec<gfc_namespace *> team_context_stack;
5592 :
5593 : gfc_namespace *
5594 17561 : get_current_team_context (void)
5595 : {
5596 17615 : return team_context_stack.is_empty () ? NULL : team_context_stack.last ();
5597 : }
5598 :
5599 :
5600 : static void
5601 97 : parse_change_team (void)
5602 : {
5603 97 : gfc_namespace *my_ns;
5604 97 : gfc_state_data s;
5605 97 : gfc_statement st;
5606 97 : vec<gfc_expr *> *team_allocs;
5607 :
5608 97 : gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM construct at %C");
5609 :
5610 97 : my_ns = gfc_build_block_ns (gfc_current_ns);
5611 :
5612 97 : new_st.op = EXEC_CHANGE_TEAM;
5613 97 : new_st.ext.block.ns = my_ns;
5614 :
5615 : /* Add all associate-names as BLOCK variables. Creating them is enough
5616 : for now, they'll get their values during trans-* phase. */
5617 97 : gfc_current_ns = my_ns;
5618 97 : if (new_st.ext.block.assoc)
5619 3 : move_associates_to_block ();
5620 :
5621 97 : accept_statement (ST_CHANGE_TEAM);
5622 97 : push_state (&s, COMP_CHANGE_TEAM, my_ns->proc_name);
5623 :
5624 : /* Push team context for tracking coarrays allocated in a team block. */
5625 97 : team_context_stack.safe_push (gfc_current_ns);
5626 :
5627 97 : loop:
5628 97 : st = parse_executable (ST_NONE);
5629 97 : switch (st)
5630 : {
5631 0 : case ST_NONE:
5632 0 : unexpected_eof ();
5633 :
5634 97 : case_end:
5635 97 : accept_statement (st);
5636 97 : my_ns->code = gfc_state_stack->head;
5637 : /* F2018(11.1.5.2): Deallocate coarray expressions allocated in this
5638 : team block, */
5639 97 : team_allocs = team_allocated_coarrays.get (gfc_current_ns);
5640 97 : if (team_allocs)
5641 18 : deallocate_allocated_coarrays (team_allocs);
5642 : /* Pop team context. */
5643 97 : team_context_stack.pop ();
5644 97 : break;
5645 :
5646 0 : default:
5647 0 : unexpected_statement (st);
5648 0 : goto loop;
5649 : }
5650 :
5651 97 : gfc_current_ns = gfc_current_ns->parent;
5652 97 : pop_state ();
5653 97 : }
5654 :
5655 : /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
5656 : handled inside of parse_executable(), because they aren't really
5657 : loop statements. */
5658 :
5659 : static void
5660 32938 : parse_do_block (void)
5661 : {
5662 32938 : gfc_statement st;
5663 32938 : gfc_code *top;
5664 32938 : gfc_state_data s;
5665 32938 : gfc_symtree *stree;
5666 32938 : gfc_exec_op do_op;
5667 :
5668 32938 : do_op = new_st.op;
5669 32938 : s.ext.end_do_label = new_st.label1;
5670 :
5671 32938 : if (do_op == EXEC_DO_CONCURRENT)
5672 : {
5673 224 : gfc_forall_iterator *fa;
5674 467 : for (fa = new_st.ext.concur.forall_iterator; fa; fa = fa->next)
5675 : {
5676 : /* Apply unroll only to innermost loop (first control
5677 : variable). */
5678 243 : if (directive_unroll != -1)
5679 : {
5680 1 : fa->annot.unroll = directive_unroll;
5681 1 : directive_unroll = -1;
5682 : }
5683 243 : if (directive_ivdep)
5684 1 : fa->annot.ivdep = directive_ivdep;
5685 243 : if (directive_vector)
5686 1 : fa->annot.vector = directive_vector;
5687 243 : if (directive_novector)
5688 2 : fa->annot.novector = directive_novector;
5689 : }
5690 224 : directive_ivdep = false;
5691 224 : directive_vector = false;
5692 224 : directive_novector = false;
5693 224 : stree = NULL;
5694 : }
5695 32714 : else if (new_st.ext.iterator != NULL)
5696 : {
5697 32182 : stree = new_st.ext.iterator->var->symtree;
5698 32182 : if (directive_unroll != -1)
5699 : {
5700 16 : new_st.ext.iterator->annot.unroll = directive_unroll;
5701 16 : directive_unroll = -1;
5702 : }
5703 32182 : if (directive_ivdep)
5704 : {
5705 2 : new_st.ext.iterator->annot.ivdep = directive_ivdep;
5706 2 : directive_ivdep = false;
5707 : }
5708 32182 : if (directive_vector)
5709 : {
5710 2 : new_st.ext.iterator->annot.vector = directive_vector;
5711 2 : directive_vector = false;
5712 : }
5713 32182 : if (directive_novector)
5714 : {
5715 2 : new_st.ext.iterator->annot.novector = directive_novector;
5716 2 : directive_novector = false;
5717 : }
5718 : }
5719 : else
5720 : stree = NULL;
5721 :
5722 32938 : accept_statement (ST_DO);
5723 :
5724 32938 : top = gfc_state_stack->tail;
5725 65652 : push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
5726 : gfc_new_block);
5727 :
5728 32938 : s.do_variable = stree;
5729 :
5730 32938 : top->block = new_level (top);
5731 32938 : top->block->op = EXEC_DO;
5732 :
5733 32939 : loop:
5734 32939 : st = parse_executable (ST_NONE);
5735 :
5736 32937 : switch (st)
5737 : {
5738 0 : case ST_NONE:
5739 0 : unexpected_eof ();
5740 :
5741 30763 : case ST_ENDDO:
5742 30763 : if (s.ext.end_do_label != NULL
5743 86 : && s.ext.end_do_label != gfc_statement_label)
5744 1 : gfc_error_now ("Statement label in ENDDO at %C doesn't match "
5745 : "DO label");
5746 :
5747 30763 : if (gfc_statement_label != NULL)
5748 : {
5749 98 : new_st.op = EXEC_NOP;
5750 98 : add_statement ();
5751 : }
5752 : break;
5753 :
5754 2173 : case ST_IMPLIED_ENDDO:
5755 : /* If the do-stmt of this DO construct has a do-construct-name,
5756 : the corresponding end-do must be an end-do-stmt (with a matching
5757 : name, but in that case we must have seen ST_ENDDO first).
5758 : We only complain about this in pedantic mode. */
5759 2173 : if (gfc_current_block () != NULL)
5760 1 : gfc_error_now ("Named block DO at %L requires matching ENDDO name",
5761 : &gfc_current_block()->declared_at);
5762 :
5763 : break;
5764 :
5765 1 : default:
5766 1 : unexpected_statement (st);
5767 1 : goto loop;
5768 : }
5769 :
5770 32936 : pop_state ();
5771 32936 : accept_statement (st);
5772 32936 : }
5773 :
5774 : /* Get the corresponding ending statement type for the OpenMP directive
5775 : OMP_ST. If it does not have one, return ST_NONE. */
5776 :
5777 : gfc_statement
5778 14109 : gfc_omp_end_stmt (gfc_statement omp_st,
5779 : bool omp_do_p, bool omp_structured_p)
5780 : {
5781 14109 : if (omp_do_p)
5782 : {
5783 5305 : switch (omp_st)
5784 : {
5785 : case ST_OMP_DISTRIBUTE: return ST_OMP_END_DISTRIBUTE;
5786 43 : case ST_OMP_DISTRIBUTE_PARALLEL_DO:
5787 43 : return ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
5788 33 : case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5789 33 : return ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
5790 51 : case ST_OMP_DISTRIBUTE_SIMD:
5791 51 : return ST_OMP_END_DISTRIBUTE_SIMD;
5792 1244 : case ST_OMP_DO: return ST_OMP_END_DO;
5793 134 : case ST_OMP_DO_SIMD: return ST_OMP_END_DO_SIMD;
5794 64 : case ST_OMP_LOOP: return ST_OMP_END_LOOP;
5795 1200 : case ST_OMP_PARALLEL_DO: return ST_OMP_END_PARALLEL_DO;
5796 297 : case ST_OMP_PARALLEL_DO_SIMD:
5797 297 : return ST_OMP_END_PARALLEL_DO_SIMD;
5798 31 : case ST_OMP_PARALLEL_LOOP:
5799 31 : return ST_OMP_END_PARALLEL_LOOP;
5800 776 : case ST_OMP_SIMD: return ST_OMP_END_SIMD;
5801 78 : case ST_OMP_TARGET_PARALLEL_DO:
5802 78 : return ST_OMP_END_TARGET_PARALLEL_DO;
5803 20 : case ST_OMP_TARGET_PARALLEL_DO_SIMD:
5804 20 : return ST_OMP_END_TARGET_PARALLEL_DO_SIMD;
5805 16 : case ST_OMP_TARGET_PARALLEL_LOOP:
5806 16 : return ST_OMP_END_TARGET_PARALLEL_LOOP;
5807 33 : case ST_OMP_TARGET_SIMD: return ST_OMP_END_TARGET_SIMD;
5808 19 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
5809 19 : return ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
5810 66 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5811 66 : return ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
5812 36 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5813 36 : return ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
5814 20 : case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5815 20 : return ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
5816 18 : case ST_OMP_TARGET_TEAMS_LOOP:
5817 18 : return ST_OMP_END_TARGET_TEAMS_LOOP;
5818 70 : case ST_OMP_TASKLOOP: return ST_OMP_END_TASKLOOP;
5819 39 : case ST_OMP_TASKLOOP_SIMD: return ST_OMP_END_TASKLOOP_SIMD;
5820 9 : case ST_OMP_MASKED_TASKLOOP: return ST_OMP_END_MASKED_TASKLOOP;
5821 15 : case ST_OMP_MASKED_TASKLOOP_SIMD:
5822 15 : return ST_OMP_END_MASKED_TASKLOOP_SIMD;
5823 15 : case ST_OMP_MASTER_TASKLOOP: return ST_OMP_END_MASTER_TASKLOOP;
5824 20 : case ST_OMP_MASTER_TASKLOOP_SIMD:
5825 20 : return ST_OMP_END_MASTER_TASKLOOP_SIMD;
5826 8 : case ST_OMP_PARALLEL_MASKED_TASKLOOP:
5827 8 : return ST_OMP_END_PARALLEL_MASKED_TASKLOOP;
5828 11 : case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
5829 11 : return ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD;
5830 13 : case ST_OMP_PARALLEL_MASTER_TASKLOOP:
5831 13 : return ST_OMP_END_PARALLEL_MASTER_TASKLOOP;
5832 19 : case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
5833 19 : return ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD;
5834 21 : case ST_OMP_TEAMS_DISTRIBUTE:
5835 21 : return ST_OMP_END_TEAMS_DISTRIBUTE;
5836 40 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5837 40 : return ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
5838 62 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5839 62 : return ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
5840 43 : case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
5841 43 : return ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
5842 30 : case ST_OMP_TEAMS_LOOP:
5843 30 : return ST_OMP_END_TEAMS_LOOP;
5844 195 : case ST_OMP_TILE:
5845 195 : return ST_OMP_END_TILE;
5846 414 : case ST_OMP_UNROLL:
5847 414 : return ST_OMP_END_UNROLL;
5848 : default:
5849 : break;
5850 : }
5851 : }
5852 :
5853 8851 : if (omp_structured_p)
5854 : {
5855 8851 : switch (omp_st)
5856 : {
5857 : case ST_OMP_ALLOCATORS:
5858 : return ST_OMP_END_ALLOCATORS;
5859 : case ST_OMP_ASSUME:
5860 : return ST_OMP_END_ASSUME;
5861 : case ST_OMP_ATOMIC:
5862 : return ST_OMP_END_ATOMIC;
5863 : case ST_OMP_DISPATCH:
5864 : return ST_OMP_END_DISPATCH;
5865 : case ST_OMP_PARALLEL:
5866 : return ST_OMP_END_PARALLEL;
5867 : case ST_OMP_PARALLEL_MASKED:
5868 : return ST_OMP_END_PARALLEL_MASKED;
5869 : case ST_OMP_PARALLEL_MASTER:
5870 : return ST_OMP_END_PARALLEL_MASTER;
5871 : case ST_OMP_PARALLEL_SECTIONS:
5872 : return ST_OMP_END_PARALLEL_SECTIONS;
5873 : case ST_OMP_SCOPE:
5874 : return ST_OMP_END_SCOPE;
5875 : case ST_OMP_SECTIONS:
5876 : return ST_OMP_END_SECTIONS;
5877 : case ST_OMP_ORDERED:
5878 : return ST_OMP_END_ORDERED;
5879 : case ST_OMP_CRITICAL:
5880 : return ST_OMP_END_CRITICAL;
5881 : case ST_OMP_MASKED:
5882 : return ST_OMP_END_MASKED;
5883 : case ST_OMP_MASTER:
5884 : return ST_OMP_END_MASTER;
5885 : case ST_OMP_SINGLE:
5886 : return ST_OMP_END_SINGLE;
5887 : case ST_OMP_TARGET:
5888 : return ST_OMP_END_TARGET;
5889 : case ST_OMP_TARGET_DATA:
5890 : return ST_OMP_END_TARGET_DATA;
5891 : case ST_OMP_TARGET_PARALLEL:
5892 : return ST_OMP_END_TARGET_PARALLEL;
5893 : case ST_OMP_TARGET_TEAMS:
5894 : return ST_OMP_END_TARGET_TEAMS;
5895 : case ST_OMP_TASK:
5896 : return ST_OMP_END_TASK;
5897 : case ST_OMP_TASKGROUP:
5898 : return ST_OMP_END_TASKGROUP;
5899 : case ST_OMP_TEAMS:
5900 : return ST_OMP_END_TEAMS;
5901 : case ST_OMP_TEAMS_DISTRIBUTE:
5902 : return ST_OMP_END_TEAMS_DISTRIBUTE;
5903 : case ST_OMP_DISTRIBUTE:
5904 : return ST_OMP_END_DISTRIBUTE;
5905 : case ST_OMP_WORKSHARE:
5906 : return ST_OMP_END_WORKSHARE;
5907 : case ST_OMP_PARALLEL_WORKSHARE:
5908 : return ST_OMP_END_PARALLEL_WORKSHARE;
5909 : case ST_OMP_BEGIN_METADIRECTIVE:
5910 : return ST_OMP_END_METADIRECTIVE;
5911 : default:
5912 : break;
5913 : }
5914 : }
5915 :
5916 : return ST_NONE;
5917 : }
5918 :
5919 : /* Parse the statements of OpenMP do/parallel do. */
5920 :
5921 : static gfc_statement
5922 5251 : parse_omp_do (gfc_statement omp_st, int nested)
5923 : {
5924 5251 : gfc_statement st;
5925 5251 : gfc_code *cp, *np;
5926 5251 : gfc_state_data s;
5927 :
5928 5251 : accept_statement (omp_st);
5929 :
5930 5251 : cp = gfc_state_stack->tail;
5931 5251 : push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5932 5251 : np = new_level (cp);
5933 5251 : np->op = cp->op;
5934 5251 : np->block = NULL;
5935 :
5936 5337 : for (;;)
5937 : {
5938 5294 : st = next_statement ();
5939 5294 : if (st == ST_NONE)
5940 2 : unexpected_eof ();
5941 5292 : else if (st == ST_DO)
5942 : break;
5943 386 : else if (st == ST_OMP_UNROLL || st == ST_OMP_TILE)
5944 : {
5945 343 : st = parse_omp_do (st, nested + 1);
5946 343 : if (st == ST_IMPLIED_ENDDO)
5947 : return st;
5948 343 : goto do_end;
5949 : }
5950 : else
5951 43 : unexpected_statement (st);
5952 : }
5953 :
5954 4906 : parse_do_block ();
5955 10155 : for (; nested; --nested)
5956 343 : pop_state ();
5957 4906 : if (gfc_statement_label != NULL
5958 68 : && gfc_state_stack->previous != NULL
5959 68 : && gfc_state_stack->previous->state == COMP_DO
5960 2 : && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
5961 : {
5962 : /* In
5963 : DO 100 I=1,10
5964 : !$OMP DO
5965 : DO J=1,10
5966 : ...
5967 : 100 CONTINUE
5968 : there should be no !$OMP END DO. */
5969 2 : pop_state ();
5970 2 : return ST_IMPLIED_ENDDO;
5971 : }
5972 :
5973 4904 : check_do_closure ();
5974 4904 : pop_state ();
5975 :
5976 4904 : st = next_statement ();
5977 5247 : do_end:
5978 5247 : gfc_statement omp_end_st = gfc_omp_end_stmt (omp_st, true, false);
5979 5247 : if (omp_st == ST_NONE)
5980 0 : gcc_unreachable ();
5981 :
5982 : /* If handling a metadirective variant, treat 'omp end metadirective'
5983 : as the expected end statement for the current construct. */
5984 5247 : if (gfc_state_stack->state == COMP_OMP_BEGIN_METADIRECTIVE)
5985 : {
5986 4 : if (st == ST_OMP_END_METADIRECTIVE)
5987 : st = omp_end_st;
5988 : else
5989 : {
5990 : /* We have found some extra statements between the loop
5991 : and the "end metadirective" which is required in a
5992 : "begin metadirective" construct, or perhaps the
5993 : "end metadirective" is missing entirely. */
5994 0 : gfc_error_now ("Expected OMP END METADIRECTIVE at %C");
5995 0 : return st;
5996 : }
5997 : }
5998 :
5999 5247 : if (st == omp_end_st)
6000 : {
6001 876 : if (new_st.op == EXEC_OMP_END_NOWAIT)
6002 : {
6003 384 : if (cp->ext.omp_clauses->nowait && new_st.ext.omp_bool)
6004 11 : gfc_error_now ("Duplicated NOWAIT clause on %s and %s at %C",
6005 : gfc_ascii_statement (omp_st),
6006 : gfc_ascii_statement (omp_end_st));
6007 384 : cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
6008 : }
6009 : else
6010 492 : gcc_assert (new_st.op == EXEC_NOP);
6011 876 : gfc_clear_new_st ();
6012 876 : gfc_commit_symbols ();
6013 876 : gfc_warning_check ();
6014 876 : st = next_statement ();
6015 : }
6016 : return st;
6017 : }
6018 :
6019 :
6020 : /* Parse the statements of OpenMP atomic directive. */
6021 :
6022 : static gfc_statement
6023 2694 : parse_omp_oacc_atomic (bool omp_p)
6024 : {
6025 2694 : gfc_statement st, st_atomic, st_end_atomic;
6026 2694 : gfc_code *cp, *np;
6027 2694 : gfc_state_data s;
6028 2694 : int count;
6029 :
6030 2694 : if (omp_p)
6031 : {
6032 2151 : st_atomic = ST_OMP_ATOMIC;
6033 2151 : if (gfc_state_stack->state == COMP_OMP_BEGIN_METADIRECTIVE)
6034 : st_end_atomic = ST_OMP_END_METADIRECTIVE;
6035 : else
6036 2149 : st_end_atomic = ST_OMP_END_ATOMIC;
6037 : }
6038 : else
6039 : {
6040 : st_atomic = ST_OACC_ATOMIC;
6041 : st_end_atomic = ST_OACC_END_ATOMIC;
6042 : }
6043 2694 : accept_statement (st_atomic);
6044 :
6045 2694 : cp = gfc_state_stack->tail;
6046 2694 : push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
6047 2694 : np = new_level (cp);
6048 2694 : np->op = cp->op;
6049 2694 : np->block = NULL;
6050 2694 : np->ext.omp_clauses = cp->ext.omp_clauses;
6051 2694 : cp->ext.omp_clauses = NULL;
6052 2694 : count = 1 + np->ext.omp_clauses->capture;
6053 :
6054 5913 : while (count)
6055 : {
6056 3219 : st = next_statement ();
6057 3219 : if (st == ST_NONE)
6058 0 : unexpected_eof ();
6059 3219 : else if (np->ext.omp_clauses->compare
6060 194 : && (st == ST_SIMPLE_IF || st == ST_IF_BLOCK))
6061 : {
6062 156 : count--;
6063 156 : if (st == ST_IF_BLOCK)
6064 : {
6065 68 : parse_if_block ();
6066 : /* With else (or elseif). */
6067 68 : if (gfc_state_stack->tail->block->block)
6068 65 : count--;
6069 : }
6070 156 : accept_statement (st);
6071 : }
6072 3063 : else if (st == ST_ASSIGNMENT
6073 3062 : && (!np->ext.omp_clauses->compare
6074 38 : || np->ext.omp_clauses->capture))
6075 : {
6076 3062 : accept_statement (st);
6077 3062 : count--;
6078 : }
6079 : else
6080 1 : unexpected_statement (st);
6081 : }
6082 :
6083 2694 : pop_state ();
6084 :
6085 2694 : st = next_statement ();
6086 2694 : if (st == st_end_atomic)
6087 : {
6088 726 : gfc_clear_new_st ();
6089 726 : gfc_commit_symbols ();
6090 726 : gfc_warning_check ();
6091 726 : st = next_statement ();
6092 : }
6093 2694 : return st;
6094 : }
6095 :
6096 :
6097 : /* Parse the statements of an OpenACC structured block. */
6098 :
6099 : static void
6100 4847 : parse_oacc_structured_block (gfc_statement acc_st)
6101 : {
6102 4847 : gfc_statement st, acc_end_st;
6103 4847 : gfc_code *cp, *np;
6104 4847 : gfc_state_data s, *sd;
6105 :
6106 16631 : for (sd = gfc_state_stack; sd; sd = sd->previous)
6107 11784 : if (sd->state == COMP_CRITICAL)
6108 2 : gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
6109 :
6110 4847 : accept_statement (acc_st);
6111 :
6112 4847 : cp = gfc_state_stack->tail;
6113 4847 : push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
6114 4847 : np = new_level (cp);
6115 4847 : np->op = cp->op;
6116 4847 : np->block = NULL;
6117 4847 : switch (acc_st)
6118 : {
6119 : case ST_OACC_PARALLEL:
6120 4847 : acc_end_st = ST_OACC_END_PARALLEL;
6121 : break;
6122 875 : case ST_OACC_KERNELS:
6123 875 : acc_end_st = ST_OACC_END_KERNELS;
6124 875 : break;
6125 321 : case ST_OACC_SERIAL:
6126 321 : acc_end_st = ST_OACC_END_SERIAL;
6127 321 : break;
6128 679 : case ST_OACC_DATA:
6129 679 : acc_end_st = ST_OACC_END_DATA;
6130 679 : break;
6131 60 : case ST_OACC_HOST_DATA:
6132 60 : acc_end_st = ST_OACC_END_HOST_DATA;
6133 60 : break;
6134 0 : default:
6135 0 : gcc_unreachable ();
6136 : }
6137 :
6138 4847 : do
6139 : {
6140 4847 : st = parse_executable (ST_NONE);
6141 4847 : if (st == ST_NONE)
6142 0 : unexpected_eof ();
6143 4847 : else if (st != acc_end_st)
6144 : {
6145 0 : gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st));
6146 0 : reject_statement ();
6147 : }
6148 : }
6149 4847 : while (st != acc_end_st);
6150 :
6151 4847 : gcc_assert (new_st.op == EXEC_NOP);
6152 :
6153 4847 : gfc_clear_new_st ();
6154 4847 : gfc_commit_symbols ();
6155 4847 : gfc_warning_check ();
6156 4847 : pop_state ();
6157 4847 : }
6158 :
6159 : /* Parse the statements of OpenACC 'loop', or combined compute 'loop'. */
6160 :
6161 : static gfc_statement
6162 5272 : parse_oacc_loop (gfc_statement acc_st)
6163 : {
6164 5272 : gfc_statement st;
6165 5272 : gfc_code *cp, *np;
6166 5272 : gfc_state_data s, *sd;
6167 :
6168 24201 : for (sd = gfc_state_stack; sd; sd = sd->previous)
6169 18929 : if (sd->state == COMP_CRITICAL)
6170 0 : gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
6171 :
6172 5272 : accept_statement (acc_st);
6173 :
6174 5272 : cp = gfc_state_stack->tail;
6175 5272 : push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
6176 5272 : np = new_level (cp);
6177 5272 : np->op = cp->op;
6178 5272 : np->block = NULL;
6179 :
6180 5278 : for (;;)
6181 : {
6182 5275 : st = next_statement ();
6183 5275 : if (st == ST_NONE)
6184 0 : unexpected_eof ();
6185 5275 : else if (st == ST_DO)
6186 : break;
6187 : else
6188 : {
6189 3 : gfc_error ("Expected DO loop at %C");
6190 3 : reject_statement ();
6191 : }
6192 : }
6193 :
6194 5272 : parse_do_block ();
6195 5272 : if (gfc_statement_label != NULL
6196 80 : && gfc_state_stack->previous != NULL
6197 80 : && gfc_state_stack->previous->state == COMP_DO
6198 0 : && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
6199 : {
6200 0 : pop_state ();
6201 0 : return ST_IMPLIED_ENDDO;
6202 : }
6203 :
6204 5272 : check_do_closure ();
6205 5272 : pop_state ();
6206 :
6207 5272 : st = next_statement ();
6208 5272 : if (st == ST_OACC_END_LOOP)
6209 2 : gfc_warning (0, "Redundant !$ACC END LOOP at %C");
6210 5272 : if ((acc_st == ST_OACC_PARALLEL_LOOP && st == ST_OACC_END_PARALLEL_LOOP) ||
6211 4345 : (acc_st == ST_OACC_KERNELS_LOOP && st == ST_OACC_END_KERNELS_LOOP) ||
6212 4322 : (acc_st == ST_OACC_SERIAL_LOOP && st == ST_OACC_END_SERIAL_LOOP) ||
6213 4173 : (acc_st == ST_OACC_LOOP && st == ST_OACC_END_LOOP))
6214 : {
6215 1101 : gcc_assert (new_st.op == EXEC_NOP);
6216 1101 : gfc_clear_new_st ();
6217 1101 : gfc_commit_symbols ();
6218 1101 : gfc_warning_check ();
6219 1101 : st = next_statement ();
6220 : }
6221 : return st;
6222 : }
6223 :
6224 :
6225 : /* Parse an OpenMP allocate block, including optional ALLOCATORS
6226 : end directive. */
6227 :
6228 : static gfc_statement
6229 74 : parse_openmp_allocate_block (gfc_statement omp_st)
6230 : {
6231 74 : gfc_statement st;
6232 74 : gfc_code *cp, *np;
6233 74 : gfc_state_data s;
6234 74 : bool empty_list = false;
6235 74 : locus empty_list_loc;
6236 74 : gfc_omp_namelist *n_first = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
6237 :
6238 74 : if (omp_st == ST_OMP_ALLOCATE_EXEC
6239 50 : && new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym == NULL)
6240 : {
6241 23 : empty_list = true;
6242 23 : empty_list_loc = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
6243 : }
6244 :
6245 74 : accept_statement (omp_st);
6246 :
6247 74 : cp = gfc_state_stack->tail;
6248 74 : push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
6249 74 : np = new_level (cp);
6250 74 : np->op = cp->op;
6251 74 : np->block = NULL;
6252 :
6253 74 : st = next_statement ();
6254 161 : while (omp_st == ST_OMP_ALLOCATE_EXEC && st == ST_OMP_ALLOCATE_EXEC)
6255 : {
6256 13 : if (empty_list && !new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym)
6257 : {
6258 1 : locus *loc = &new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
6259 1 : gfc_error_now ("%s statements at %L and %L have both no list item but"
6260 : " only one may", gfc_ascii_statement (st),
6261 : &empty_list_loc, loc);
6262 1 : empty_list = false;
6263 : }
6264 13 : if (!new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->sym)
6265 : {
6266 3 : empty_list = true;
6267 3 : empty_list_loc = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE]->where;
6268 : }
6269 22 : for ( ; n_first->next; n_first = n_first->next)
6270 : ;
6271 13 : n_first->next = new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE];
6272 13 : new_st.ext.omp_clauses->lists[OMP_LIST_ALLOCATE] = NULL;
6273 13 : gfc_free_omp_clauses (new_st.ext.omp_clauses);
6274 :
6275 13 : accept_statement (ST_NONE);
6276 13 : st = next_statement ();
6277 : }
6278 74 : if (st != ST_ALLOCATE && omp_st == ST_OMP_ALLOCATE_EXEC)
6279 1 : gfc_error_now ("Unexpected %s at %C; expected ALLOCATE or %s statement",
6280 : gfc_ascii_statement (st), gfc_ascii_statement (omp_st));
6281 73 : else if (st != ST_ALLOCATE)
6282 3 : gfc_error_now ("Unexpected %s at %C; expected ALLOCATE statement after %s",
6283 : gfc_ascii_statement (st), gfc_ascii_statement (omp_st));
6284 74 : accept_statement (st);
6285 74 : pop_state ();
6286 74 : st = next_statement ();
6287 74 : if (omp_st == ST_OMP_ALLOCATORS
6288 24 : && (st == ST_OMP_END_ALLOCATORS
6289 20 : || (st == ST_OMP_END_METADIRECTIVE
6290 0 : && gfc_state_stack->state == COMP_OMP_BEGIN_METADIRECTIVE)))
6291 : {
6292 4 : accept_statement (st);
6293 4 : st = next_statement ();
6294 : }
6295 74 : return st;
6296 : }
6297 :
6298 :
6299 : /* Parse the statements of an OpenMP structured block. */
6300 :
6301 : static gfc_statement
6302 8804 : parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
6303 : {
6304 8804 : gfc_statement st, omp_end_st, first_st;
6305 8804 : gfc_code *cp, *np;
6306 8804 : gfc_state_data s, s2;
6307 :
6308 8804 : accept_statement (omp_st);
6309 :
6310 8804 : cp = gfc_state_stack->tail;
6311 8804 : push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
6312 8804 : np = new_level (cp);
6313 8804 : np->op = cp->op;
6314 8804 : np->block = NULL;
6315 :
6316 8804 : omp_end_st = gfc_omp_end_stmt (omp_st, false, true);
6317 8804 : if (omp_end_st == ST_NONE)
6318 0 : gcc_unreachable ();
6319 :
6320 : /* If handling a metadirective variant, treat 'omp end metadirective'
6321 : as the expected end statement for the current construct. */
6322 8804 : if (gfc_state_stack->previous != NULL
6323 8804 : && gfc_state_stack->previous->state == COMP_OMP_BEGIN_METADIRECTIVE)
6324 8804 : omp_end_st = ST_OMP_END_METADIRECTIVE;
6325 :
6326 8804 : bool block_construct = false;
6327 8804 : gfc_namespace *my_ns = NULL;
6328 8804 : gfc_namespace *my_parent = NULL;
6329 :
6330 8804 : first_st = st = next_statement ();
6331 :
6332 8804 : if (st == ST_BLOCK)
6333 : {
6334 : /* Adjust state to a strictly-structured block, now that we found that
6335 : the body starts with a BLOCK construct. */
6336 404 : s.state = COMP_OMP_STRICTLY_STRUCTURED_BLOCK;
6337 :
6338 404 : block_construct = true;
6339 404 : gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
6340 :
6341 404 : my_ns = gfc_build_block_ns (gfc_current_ns);
6342 404 : new_st.op = EXEC_BLOCK;
6343 404 : new_st.ext.block.ns = my_ns;
6344 404 : new_st.ext.block.assoc = NULL;
6345 404 : accept_statement (ST_BLOCK);
6346 :
6347 404 : push_state (&s2, COMP_BLOCK, my_ns->proc_name);
6348 404 : gfc_current_ns = my_ns;
6349 404 : my_parent = my_ns->parent;
6350 404 : if (omp_st == ST_OMP_SECTIONS
6351 404 : || omp_st == ST_OMP_PARALLEL_SECTIONS)
6352 : {
6353 2 : np = new_level (cp);
6354 2 : np->op = cp->op;
6355 : }
6356 :
6357 404 : first_st = next_statement ();
6358 404 : st = parse_spec (first_st);
6359 : }
6360 :
6361 8804 : if (omp_end_st == ST_OMP_END_TARGET)
6362 2182 : switch (first_st)
6363 : {
6364 192 : case ST_OMP_TEAMS:
6365 192 : case ST_OMP_TEAMS_DISTRIBUTE:
6366 192 : case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
6367 192 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
6368 192 : case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
6369 192 : case ST_OMP_TEAMS_LOOP:
6370 192 : case ST_OMP_METADIRECTIVE:
6371 192 : case ST_OMP_BEGIN_METADIRECTIVE:
6372 192 : {
6373 192 : gfc_state_data *stk = gfc_state_stack->previous;
6374 192 : if (stk->state == COMP_OMP_STRICTLY_STRUCTURED_BLOCK)
6375 20 : stk = stk->previous;
6376 192 : stk->tail->ext.omp_clauses->target_first_st_is_teams_or_meta = true;
6377 192 : break;
6378 : }
6379 : default:
6380 : break;
6381 : }
6382 :
6383 9044 : do
6384 : {
6385 9044 : if (workshare_stmts_only)
6386 : {
6387 : /* Inside of !$omp workshare, only
6388 : scalar assignments
6389 : array assignments
6390 : where statements and constructs
6391 : forall statements and constructs
6392 : !$omp atomic
6393 : !$omp critical
6394 : !$omp parallel
6395 : are allowed. For !$omp critical these
6396 : restrictions apply recursively. */
6397 : bool cycle = true;
6398 :
6399 339 : for (;;)
6400 : {
6401 339 : switch (st)
6402 : {
6403 0 : case ST_NONE:
6404 0 : unexpected_eof ();
6405 :
6406 175 : case ST_ASSIGNMENT:
6407 175 : case ST_WHERE:
6408 175 : case ST_FORALL:
6409 175 : accept_statement (st);
6410 175 : break;
6411 :
6412 6 : case ST_WHERE_BLOCK:
6413 6 : parse_where_block ();
6414 6 : break;
6415 :
6416 12 : case ST_FORALL_BLOCK:
6417 12 : parse_forall_block ();
6418 12 : break;
6419 :
6420 0 : case ST_OMP_ALLOCATE_EXEC:
6421 0 : case ST_OMP_ALLOCATORS:
6422 0 : st = parse_openmp_allocate_block (st);
6423 0 : continue;
6424 :
6425 13 : case ST_OMP_ASSUME:
6426 13 : case ST_OMP_PARALLEL:
6427 13 : case ST_OMP_PARALLEL_MASKED:
6428 13 : case ST_OMP_PARALLEL_MASTER:
6429 13 : case ST_OMP_PARALLEL_SECTIONS:
6430 13 : st = parse_omp_structured_block (st, false);
6431 12 : continue;
6432 :
6433 14 : case ST_OMP_PARALLEL_WORKSHARE:
6434 14 : case ST_OMP_CRITICAL:
6435 14 : st = parse_omp_structured_block (st, true);
6436 14 : continue;
6437 :
6438 3 : case ST_OMP_PARALLEL_DO:
6439 3 : case ST_OMP_PARALLEL_DO_SIMD:
6440 3 : st = parse_omp_do (st, 0);
6441 3 : continue;
6442 :
6443 8 : case ST_OMP_ATOMIC:
6444 8 : st = parse_omp_oacc_atomic (true);
6445 8 : continue;
6446 :
6447 : default:
6448 : cycle = false;
6449 : break;
6450 : }
6451 :
6452 193 : if (!cycle)
6453 : break;
6454 :
6455 193 : st = next_statement ();
6456 : }
6457 : }
6458 : else
6459 8935 : st = parse_executable (st);
6460 9028 : if (st == ST_NONE)
6461 0 : unexpected_eof ();
6462 9028 : else if (st == ST_OMP_SECTION
6463 257 : && (omp_st == ST_OMP_SECTIONS
6464 257 : || omp_st == ST_OMP_PARALLEL_SECTIONS))
6465 : {
6466 257 : np = new_level (np);
6467 257 : np->op = cp->op;
6468 257 : np->block = NULL;
6469 257 : st = next_statement ();
6470 : }
6471 8771 : else if (block_construct && st == ST_END_BLOCK)
6472 : {
6473 404 : accept_statement (st);
6474 404 : gfc_current_ns->code = gfc_state_stack->head;
6475 404 : gfc_current_ns = my_parent;
6476 404 : pop_state (); /* Inner BLOCK */
6477 404 : pop_state (); /* Outer COMP_OMP_STRICTLY_STRUCTURED_BLOCK */
6478 :
6479 404 : st = next_statement ();
6480 404 : if (st == omp_end_st)
6481 : {
6482 112 : accept_statement (st);
6483 112 : st = next_statement ();
6484 : }
6485 292 : else if (omp_end_st == ST_OMP_END_METADIRECTIVE)
6486 : {
6487 : /* We have found some extra statements between the END BLOCK
6488 : and the "end metadirective" which is required in a
6489 : "begin metadirective" construct, or perhaps the
6490 : "end metadirective" is missing entirely. */
6491 4 : gfc_error_now ("Expected OMP END METADIRECTIVE at %C");
6492 : }
6493 404 : return st;
6494 : }
6495 8367 : else if (st != omp_end_st || block_construct)
6496 : {
6497 4 : unexpected_statement (st);
6498 4 : st = next_statement ();
6499 : }
6500 : }
6501 8624 : while (st != omp_end_st);
6502 :
6503 8384 : switch (new_st.op)
6504 : {
6505 2265 : case EXEC_OMP_END_NOWAIT:
6506 2265 : if (cp->ext.omp_clauses->nowait && new_st.ext.omp_bool)
6507 6 : gfc_error_now ("Duplicated NOWAIT clause on %s and %s at %C",
6508 : gfc_ascii_statement (omp_st),
6509 : gfc_ascii_statement (omp_end_st));
6510 2265 : cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
6511 2265 : break;
6512 150 : case EXEC_OMP_END_CRITICAL:
6513 150 : if (((cp->ext.omp_clauses->critical_name == NULL)
6514 150 : ^ (new_st.ext.omp_name == NULL))
6515 150 : || (new_st.ext.omp_name != NULL
6516 44 : && strcmp (cp->ext.omp_clauses->critical_name,
6517 : new_st.ext.omp_name) != 0))
6518 0 : gfc_error ("Name after !$omp critical and !$omp end critical does "
6519 : "not match at %C");
6520 150 : free (const_cast<char *> (new_st.ext.omp_name));
6521 150 : new_st.ext.omp_name = NULL;
6522 150 : break;
6523 547 : case EXEC_OMP_END_SINGLE:
6524 547 : if (cp->ext.omp_clauses->nowait && new_st.ext.omp_clauses->nowait)
6525 1 : gfc_error_now ("Duplicated NOWAIT clause on %s and %s at %C",
6526 : gfc_ascii_statement (omp_st),
6527 : gfc_ascii_statement (omp_end_st));
6528 547 : cp->ext.omp_clauses->nowait |= new_st.ext.omp_clauses->nowait;
6529 547 : if (cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE])
6530 : {
6531 : gfc_omp_namelist *nl;
6532 : for (nl = cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
6533 5 : nl->next; nl = nl->next)
6534 : ;
6535 5 : nl->next = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
6536 : }
6537 : else
6538 542 : cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
6539 542 : = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
6540 547 : new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
6541 547 : gfc_free_omp_clauses (new_st.ext.omp_clauses);
6542 547 : break;
6543 : case EXEC_NOP:
6544 : break;
6545 0 : default:
6546 0 : gcc_unreachable ();
6547 : }
6548 :
6549 8384 : gfc_clear_new_st ();
6550 8384 : gfc_commit_symbols ();
6551 8384 : gfc_warning_check ();
6552 8384 : pop_state ();
6553 8384 : st = next_statement ();
6554 8384 : return st;
6555 : }
6556 :
6557 : static gfc_statement
6558 154 : parse_omp_dispatch (void)
6559 : {
6560 154 : gfc_statement st;
6561 154 : gfc_code *cp, *np;
6562 154 : gfc_state_data s;
6563 :
6564 154 : accept_statement (ST_OMP_DISPATCH);
6565 :
6566 154 : cp = gfc_state_stack->tail;
6567 154 : push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
6568 154 : np = new_level (cp);
6569 154 : np->op = cp->op;
6570 154 : np->block = NULL;
6571 :
6572 154 : st = next_statement ();
6573 154 : if (st == ST_NONE)
6574 : {
6575 1 : pop_state ();
6576 1 : return st;
6577 : }
6578 153 : if (st == ST_CALL || st == ST_ASSIGNMENT)
6579 150 : accept_statement (st);
6580 : else
6581 : {
6582 3 : gfc_error ("%<OMP DISPATCH%> directive must be followed by a procedure "
6583 : "call with optional assignment at %C");
6584 3 : reject_statement ();
6585 : }
6586 153 : pop_state ();
6587 153 : st = next_statement ();
6588 153 : if (st == ST_OMP_END_DISPATCH
6589 147 : || (st == ST_OMP_END_METADIRECTIVE
6590 1 : && gfc_state_stack->state == COMP_OMP_BEGIN_METADIRECTIVE))
6591 : {
6592 7 : if (cp->ext.omp_clauses->nowait && new_st.ext.omp_bool)
6593 1 : gfc_error_now ("Duplicated NOWAIT clause on !$OMP DISPATCH and !$OMP "
6594 : "END DISPATCH at %C");
6595 7 : cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
6596 7 : accept_statement (st);
6597 7 : st = next_statement ();
6598 : }
6599 : return st;
6600 : }
6601 :
6602 : static gfc_statement
6603 122 : parse_omp_metadirective_body (gfc_statement omp_st)
6604 : {
6605 122 : gfc_omp_variant *variant
6606 : = new_st.ext.omp_variants;
6607 122 : locus body_locus = gfc_current_locus;
6608 122 : bool saw_error = false;
6609 :
6610 122 : accept_statement (omp_st);
6611 :
6612 122 : gfc_statement next_st = ST_NONE;
6613 122 : locus next_loc;
6614 :
6615 506 : while (variant)
6616 : {
6617 263 : gfc_current_locus = body_locus;
6618 263 : gfc_state_data s;
6619 263 : bool workshare_p
6620 263 : = (variant->stmt == ST_OMP_WORKSHARE
6621 263 : || variant->stmt == ST_OMP_PARALLEL_WORKSHARE);
6622 63 : enum gfc_compile_state new_state
6623 : = (omp_st == ST_OMP_METADIRECTIVE
6624 263 : ? COMP_OMP_METADIRECTIVE : COMP_OMP_BEGIN_METADIRECTIVE);
6625 :
6626 263 : new_st = *variant->code;
6627 263 : push_state (&s, new_state, NULL);
6628 :
6629 263 : gfc_statement st;
6630 263 : bool old_in_metadirective_body = gfc_in_omp_metadirective_body;
6631 263 : gfc_in_omp_metadirective_body = true;
6632 :
6633 263 : gfc_omp_metadirective_region_count++;
6634 263 : gfc_omp_metadirective_region_stack.safe_push (
6635 : gfc_omp_metadirective_region_count);
6636 :
6637 263 : switch (variant->stmt)
6638 : {
6639 32 : case_omp_structured_block:
6640 32 : st = parse_omp_structured_block (variant->stmt, workshare_p);
6641 32 : break;
6642 143 : case_omp_do:
6643 143 : st = parse_omp_do (variant->stmt, 0);
6644 : /* TODO: Does st == ST_IMPLIED_ENDDO need special handling? */
6645 143 : break;
6646 0 : case ST_OMP_ALLOCATORS:
6647 0 : st = parse_openmp_allocate_block (variant->stmt);
6648 0 : break;
6649 4 : case ST_OMP_ATOMIC:
6650 4 : st = parse_omp_oacc_atomic (true);
6651 4 : break;
6652 1 : case ST_OMP_DISPATCH:
6653 1 : st = parse_omp_dispatch ();
6654 1 : break;
6655 83 : default:
6656 83 : accept_statement (variant->stmt);
6657 83 : st = parse_executable (next_statement ());
6658 83 : break;
6659 : }
6660 :
6661 262 : if (gfc_state_stack->state == COMP_OMP_METADIRECTIVE
6662 262 : && startswith (gfc_ascii_statement (st), "!$OMP END "))
6663 : {
6664 132 : for (gfc_state_data *p = gfc_state_stack; p; p = p->previous)
6665 131 : if (p->state == COMP_OMP_STRUCTURED_BLOCK
6666 88 : || p->state == COMP_OMP_BEGIN_METADIRECTIVE)
6667 64 : goto finish;
6668 1 : gfc_error ("Unexpected %s statement in OMP METADIRECTIVE "
6669 : "block at %C",
6670 : gfc_ascii_statement (st));
6671 1 : reject_statement ();
6672 1 : st = next_statement ();
6673 : }
6674 :
6675 262 : finish:
6676 :
6677 : /* Sanity-check that each variant finishes parsing at the same place. */
6678 262 : if (next_st == ST_NONE)
6679 : {
6680 121 : next_st = st;
6681 121 : next_loc = gfc_current_locus;
6682 : }
6683 141 : else if (st != next_st
6684 136 : || next_loc.nextc != gfc_current_locus.nextc
6685 135 : || next_loc.u.lb != gfc_current_locus.u.lb)
6686 : {
6687 6 : saw_error = true;
6688 6 : next_st = st;
6689 6 : next_loc = gfc_current_locus;
6690 : }
6691 :
6692 262 : gfc_in_omp_metadirective_body = old_in_metadirective_body;
6693 :
6694 262 : if (gfc_state_stack->head)
6695 261 : *variant->code = *gfc_state_stack->head;
6696 262 : pop_state ();
6697 :
6698 262 : gfc_omp_metadirective_region_stack.pop ();
6699 262 : int outer_omp_metadirective_region
6700 262 : = gfc_omp_metadirective_region_stack.last ();
6701 :
6702 : /* Rebind labels in the last statement -- which is the first statement
6703 : past the end of the metadirective body -- to the outer region. */
6704 262 : if (gfc_statement_label)
6705 18 : gfc_statement_label = gfc_rebind_label (gfc_statement_label,
6706 : outer_omp_metadirective_region);
6707 262 : if ((new_st.op == EXEC_READ || new_st.op == EXEC_WRITE)
6708 6 : && new_st.ext.dt->format_label
6709 6 : && new_st.ext.dt->format_label != &format_asterisk)
6710 4 : new_st.ext.dt->format_label
6711 4 : = gfc_rebind_label (new_st.ext.dt->format_label,
6712 : outer_omp_metadirective_region);
6713 262 : if (new_st.label1)
6714 4 : new_st.label1
6715 4 : = gfc_rebind_label (new_st.label1, outer_omp_metadirective_region);
6716 262 : if (new_st.here)
6717 18 : new_st.here
6718 18 : = gfc_rebind_label (new_st.here, outer_omp_metadirective_region);
6719 :
6720 262 : gfc_commit_symbols ();
6721 262 : gfc_warning_check ();
6722 262 : if (variant->next)
6723 141 : gfc_clear_new_st ();
6724 :
6725 262 : variant = variant->next;
6726 : }
6727 :
6728 121 : if (saw_error)
6729 : {
6730 6 : if (omp_st == ST_OMP_METADIRECTIVE)
6731 2 : gfc_error_now ("Variants in a metadirective at %L have "
6732 : "different associations; "
6733 : "consider using a BLOCK construct "
6734 : "or BEGIN/END METADIRECTIVE", &body_locus);
6735 : else
6736 4 : gfc_error_now ("Variants in a metadirective at %L have "
6737 : "different associations; "
6738 : "consider using a BLOCK construct", &body_locus);
6739 : }
6740 :
6741 121 : return next_st;
6742 : }
6743 :
6744 : /* Accept a series of executable statements. We return the first
6745 : statement that doesn't fit to the caller. Any block statements are
6746 : passed on to the correct handler, which usually passes the buck
6747 : right back here. */
6748 :
6749 : static gfc_statement
6750 152220 : parse_executable (gfc_statement st)
6751 : {
6752 152220 : int close_flag;
6753 152220 : bool one_stmt_p = false;
6754 152220 : in_exec_part = true;
6755 :
6756 152220 : if (st == ST_NONE)
6757 69898 : st = next_statement ();
6758 :
6759 899056 : for (;;)
6760 : {
6761 : /* Only parse one statement for the form of metadirective without
6762 : an explicit begin..end. */
6763 899056 : if (gfc_state_stack->state == COMP_OMP_METADIRECTIVE && one_stmt_p)
6764 : return st;
6765 899002 : one_stmt_p = true;
6766 :
6767 899002 : close_flag = check_do_closure ();
6768 899002 : if (close_flag)
6769 1717 : switch (st)
6770 : {
6771 0 : case ST_GOTO:
6772 0 : case ST_END_PROGRAM:
6773 0 : case ST_RETURN:
6774 0 : case ST_EXIT:
6775 0 : case ST_END_FUNCTION:
6776 0 : case ST_CYCLE:
6777 0 : case ST_PAUSE:
6778 0 : case ST_STOP:
6779 0 : case ST_ERROR_STOP:
6780 0 : case ST_END_SUBROUTINE:
6781 0 : case ST_END_TEAM:
6782 :
6783 0 : case ST_DO:
6784 0 : case ST_FORALL:
6785 0 : case ST_WHERE:
6786 0 : case ST_SELECT_CASE:
6787 0 : gfc_error ("%s statement at %C cannot terminate a non-block "
6788 : "DO loop", gfc_ascii_statement (st));
6789 0 : break;
6790 :
6791 : default:
6792 : break;
6793 : }
6794 :
6795 899002 : switch (st)
6796 : {
6797 12 : case ST_NONE:
6798 12 : unexpected_eof ();
6799 :
6800 23 : case ST_DATA:
6801 23 : gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the "
6802 : "first executable statement");
6803 : /* Fall through. */
6804 :
6805 676630 : case ST_FORMAT:
6806 676630 : case ST_ENTRY:
6807 676630 : case_executable:
6808 676630 : accept_statement (st);
6809 676630 : if (close_flag == 1)
6810 : return ST_IMPLIED_ENDDO;
6811 : break;
6812 :
6813 1080 : case ST_BLOCK:
6814 1080 : parse_block_construct ();
6815 1080 : break;
6816 :
6817 1548 : case ST_ASSOCIATE:
6818 1548 : parse_associate ();
6819 1548 : break;
6820 :
6821 97 : case ST_CHANGE_TEAM:
6822 97 : parse_change_team ();
6823 97 : break;
6824 :
6825 14870 : case ST_IF_BLOCK:
6826 14870 : parse_if_block ();
6827 14870 : break;
6828 :
6829 533 : case ST_SELECT_CASE:
6830 533 : parse_select_block ();
6831 533 : break;
6832 :
6833 3083 : case ST_SELECT_TYPE:
6834 3083 : parse_select_type_block ();
6835 3083 : break;
6836 :
6837 1036 : case ST_SELECT_RANK:
6838 1036 : parse_select_rank_block ();
6839 1036 : break;
6840 :
6841 22760 : case ST_DO:
6842 22760 : parse_do_block ();
6843 22758 : if (check_do_closure () == 1)
6844 : return ST_IMPLIED_ENDDO;
6845 : break;
6846 :
6847 54 : case ST_CRITICAL:
6848 54 : parse_critical_block ();
6849 54 : break;
6850 :
6851 279 : case ST_WHERE_BLOCK:
6852 279 : parse_where_block ();
6853 279 : break;
6854 :
6855 417 : case ST_FORALL_BLOCK:
6856 417 : parse_forall_block ();
6857 417 : break;
6858 :
6859 5272 : case ST_OACC_PARALLEL_LOOP:
6860 5272 : case ST_OACC_KERNELS_LOOP:
6861 5272 : case ST_OACC_SERIAL_LOOP:
6862 5272 : case ST_OACC_LOOP:
6863 5272 : st = parse_oacc_loop (st);
6864 5272 : if (st == ST_IMPLIED_ENDDO)
6865 : return st;
6866 5272 : continue;
6867 :
6868 4847 : case ST_OACC_PARALLEL:
6869 4847 : case ST_OACC_KERNELS:
6870 4847 : case ST_OACC_SERIAL:
6871 4847 : case ST_OACC_DATA:
6872 4847 : case ST_OACC_HOST_DATA:
6873 4847 : parse_oacc_structured_block (st);
6874 4847 : break;
6875 :
6876 74 : case ST_OMP_ALLOCATE_EXEC:
6877 74 : case ST_OMP_ALLOCATORS:
6878 74 : st = parse_openmp_allocate_block (st);
6879 74 : continue;
6880 :
6881 8745 : case_omp_structured_block:
6882 17476 : st = parse_omp_structured_block (st,
6883 8745 : st == ST_OMP_WORKSHARE
6884 8745 : || st == ST_OMP_PARALLEL_WORKSHARE);
6885 8731 : continue;
6886 :
6887 4762 : case_omp_do:
6888 4762 : st = parse_omp_do (st, 0);
6889 4760 : if (st == ST_IMPLIED_ENDDO)
6890 : return st;
6891 4758 : continue;
6892 :
6893 543 : case ST_OACC_ATOMIC:
6894 543 : st = parse_omp_oacc_atomic (false);
6895 543 : continue;
6896 :
6897 2139 : case ST_OMP_ATOMIC:
6898 2139 : st = parse_omp_oacc_atomic (true);
6899 2139 : continue;
6900 :
6901 153 : case ST_OMP_DISPATCH:
6902 153 : st = parse_omp_dispatch ();
6903 153 : continue;
6904 :
6905 122 : case ST_OMP_METADIRECTIVE:
6906 122 : case ST_OMP_BEGIN_METADIRECTIVE:
6907 122 : st = parse_omp_metadirective_body (st);
6908 121 : continue;
6909 :
6910 55 : case ST_OMP_END_METADIRECTIVE:
6911 55 : if (gfc_state_stack->state == COMP_OMP_BEGIN_METADIRECTIVE)
6912 28 : return next_statement ();
6913 : else
6914 : return st;
6915 :
6916 : default:
6917 : return st;
6918 : }
6919 :
6920 725046 : if (directive_unroll != -1)
6921 1 : gfc_error ("%<GCC unroll%> directive not at the start of a loop at %C");
6922 :
6923 725046 : if (directive_ivdep)
6924 0 : gfc_error ("%<GCC ivdep%> directive not at the start of a loop at %C");
6925 :
6926 725046 : if (directive_vector)
6927 0 : gfc_error ("%<GCC vector%> directive not at the start of a loop at %C");
6928 :
6929 725046 : if (directive_novector)
6930 0 : gfc_error ("%<GCC novector%> "
6931 : "directive not at the start of a loop at %C");
6932 :
6933 725046 : st = next_statement ();
6934 : }
6935 : }
6936 :
6937 :
6938 : /* Update statement function formal argument lists that reference OLD_SYM
6939 : to point to NEW_SYM instead. This prevents use-after-free when
6940 : gfc_fixup_sibling_symbols replaces and frees a symbol that is also
6941 : used as a statement function dummy argument (PR95879). */
6942 :
6943 : static void
6944 80197 : fixup_st_func_formals (gfc_symtree *st, gfc_symbol *old_sym,
6945 : gfc_symbol *new_sym)
6946 : {
6947 80197 : if (st == NULL)
6948 : return;
6949 :
6950 38383 : fixup_st_func_formals (st->left, old_sym, new_sym);
6951 38383 : fixup_st_func_formals (st->right, old_sym, new_sym);
6952 :
6953 38383 : if (st->n.sym && st->n.sym->attr.proc == PROC_ST_FUNCTION)
6954 4 : for (gfc_formal_arglist *fa = st->n.sym->formal; fa; fa = fa->next)
6955 2 : if (fa->sym == old_sym)
6956 2 : fa->sym = new_sym;
6957 : }
6958 :
6959 :
6960 : /* Fix the symbols for sibling functions. These are incorrectly added to
6961 : the child namespace as the parser didn't know about this procedure. */
6962 :
6963 : static void
6964 201924 : gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
6965 : {
6966 201924 : gfc_namespace *ns;
6967 201924 : gfc_symtree *st;
6968 201924 : gfc_symbol *old_sym;
6969 201924 : bool imported;
6970 :
6971 366520 : for (ns = siblings; ns; ns = ns->sibling)
6972 : {
6973 164596 : st = gfc_find_symtree (ns->sym_root, sym->name);
6974 :
6975 164596 : if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
6976 123855 : goto fixup_contained;
6977 :
6978 40741 : if ((st->n.sym->attr.flavor == FL_DERIVED
6979 0 : && sym->attr.generic && sym->attr.function)
6980 40741 : ||(sym->attr.flavor == FL_DERIVED
6981 0 : && st->n.sym->attr.generic && st->n.sym->attr.function))
6982 0 : goto fixup_contained;
6983 :
6984 40741 : old_sym = st->n.sym;
6985 40741 : imported = old_sym->attr.imported == 1;
6986 40741 : if (old_sym->ns == ns
6987 3655 : && !old_sym->attr.contained
6988 :
6989 : /* By 14.6.1.3, host association should be excluded
6990 : for the following. */
6991 3640 : && !(old_sym->attr.external
6992 3640 : || (old_sym->ts.type != BT_UNKNOWN
6993 193 : && !old_sym->attr.implicit_type)
6994 3448 : || old_sym->attr.flavor == FL_PARAMETER
6995 3448 : || old_sym->attr.use_assoc
6996 3441 : || old_sym->attr.in_common
6997 3441 : || old_sym->attr.in_equivalence
6998 3441 : || old_sym->attr.data
6999 3441 : || old_sym->attr.dummy
7000 3441 : || old_sym->attr.result
7001 3441 : || old_sym->attr.dimension
7002 3441 : || old_sym->attr.allocatable
7003 3441 : || old_sym->attr.intrinsic
7004 3441 : || old_sym->attr.generic
7005 3433 : || old_sym->attr.flavor == FL_NAMELIST
7006 3432 : || old_sym->attr.flavor == FL_LABEL
7007 3431 : || old_sym->attr.proc == PROC_ST_FUNCTION))
7008 : {
7009 : /* Replace it with the symbol from the parent namespace. */
7010 3431 : st->n.sym = sym;
7011 3431 : sym->refs++;
7012 3431 : if (imported)
7013 1 : sym->attr.imported = 1;
7014 :
7015 : /* Update statement function formal argument lists that still
7016 : reference old_sym before releasing it (PR95879). */
7017 3431 : fixup_st_func_formals (ns->sym_root, old_sym, sym);
7018 :
7019 3431 : gfc_release_symbol (old_sym);
7020 : }
7021 :
7022 37310 : fixup_contained:
7023 : /* Do the same for any contained procedures. */
7024 164596 : gfc_fixup_sibling_symbols (sym, ns->contained);
7025 : }
7026 201924 : }
7027 :
7028 : static void
7029 15247 : parse_contained (int module)
7030 : {
7031 15247 : gfc_namespace *ns, *parent_ns, *tmp;
7032 15247 : gfc_state_data s1, s2;
7033 15247 : gfc_statement st;
7034 15247 : gfc_symbol *sym;
7035 15247 : gfc_entry_list *el;
7036 15247 : locus old_loc;
7037 15247 : int contains_statements = 0;
7038 15247 : int seen_error = 0;
7039 :
7040 15247 : push_state (&s1, COMP_CONTAINS, NULL);
7041 15247 : parent_ns = gfc_current_ns;
7042 :
7043 52319 : do
7044 : {
7045 52319 : gfc_current_ns = gfc_get_namespace (parent_ns, 1);
7046 :
7047 52319 : gfc_current_ns->sibling = parent_ns->contained;
7048 52319 : parent_ns->contained = gfc_current_ns;
7049 :
7050 52344 : next:
7051 : /* Process the next available statement. We come here if we got an error
7052 : and rejected the last statement. */
7053 52344 : old_loc = gfc_current_locus;
7054 52344 : st = next_statement ();
7055 :
7056 52344 : switch (st)
7057 : {
7058 1 : case ST_NONE:
7059 1 : unexpected_eof ();
7060 :
7061 37074 : case ST_FUNCTION:
7062 37074 : case ST_SUBROUTINE:
7063 37074 : contains_statements = 1;
7064 37074 : accept_statement (st);
7065 :
7066 63482 : push_state (&s2,
7067 : (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
7068 : gfc_new_block);
7069 :
7070 : /* For internal procedures, create/update the symbol in the
7071 : parent namespace. */
7072 :
7073 37074 : if (!module)
7074 : {
7075 19654 : if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
7076 0 : gfc_error ("Contained procedure %qs at %C is already "
7077 : "ambiguous", gfc_new_block->name);
7078 : else
7079 : {
7080 19654 : if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
7081 : sym->name,
7082 19654 : &gfc_new_block->declared_at))
7083 : {
7084 19653 : if (st == ST_FUNCTION)
7085 4643 : gfc_add_function (&sym->attr, sym->name,
7086 4643 : &gfc_new_block->declared_at);
7087 : else
7088 15010 : gfc_add_subroutine (&sym->attr, sym->name,
7089 15010 : &gfc_new_block->declared_at);
7090 : }
7091 : }
7092 :
7093 19654 : gfc_commit_symbols ();
7094 : }
7095 : else
7096 17420 : sym = gfc_new_block;
7097 :
7098 : /* Mark this as a contained function, so it isn't replaced
7099 : by other module functions. */
7100 37074 : sym->attr.contained = 1;
7101 :
7102 : /* Set implicit_pure so that it can be reset if any of the
7103 : tests for purity fail. This is used for some optimisation
7104 : during translation. */
7105 37074 : if (!sym->attr.pure)
7106 34576 : sym->attr.implicit_pure = 1;
7107 :
7108 37074 : parse_progunit (ST_NONE);
7109 :
7110 : /* Fix up any sibling functions that refer to this one. */
7111 37072 : gfc_fixup_sibling_symbols (sym, gfc_current_ns);
7112 : /* Or refer to any of its alternate entry points. */
7113 37328 : for (el = gfc_current_ns->entries; el; el = el->next)
7114 256 : gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
7115 :
7116 37072 : gfc_current_ns->code = s2.head;
7117 37072 : gfc_current_ns = parent_ns;
7118 :
7119 37072 : pop_state ();
7120 37072 : break;
7121 :
7122 : /* These statements are associated with the end of the host unit. */
7123 15244 : case ST_END_FUNCTION:
7124 15244 : case ST_END_MODULE:
7125 15244 : case ST_END_SUBMODULE:
7126 15244 : case ST_END_PROGRAM:
7127 15244 : case ST_END_SUBROUTINE:
7128 15244 : accept_statement (st);
7129 15244 : gfc_current_ns->code = s1.head;
7130 15244 : break;
7131 :
7132 25 : default:
7133 25 : gfc_error ("Unexpected %s statement in CONTAINS section at %C",
7134 : gfc_ascii_statement (st));
7135 25 : reject_statement ();
7136 25 : seen_error = 1;
7137 25 : goto next;
7138 52316 : break;
7139 : }
7140 : }
7141 52316 : while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
7142 51465 : && st != ST_END_MODULE && st != ST_END_SUBMODULE
7143 96289 : && st != ST_END_PROGRAM);
7144 :
7145 : /* The first namespace in the list is guaranteed to not have
7146 : anything (worthwhile) in it. */
7147 15244 : tmp = gfc_current_ns;
7148 15244 : gfc_current_ns = parent_ns;
7149 15244 : if (seen_error && tmp->refs > 1)
7150 0 : gfc_free_namespace (tmp);
7151 :
7152 15244 : ns = gfc_current_ns->contained;
7153 15244 : gfc_current_ns->contained = ns->sibling;
7154 15244 : gfc_free_namespace (ns);
7155 :
7156 15244 : pop_state ();
7157 15244 : if (!contains_statements)
7158 68 : gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without "
7159 : "FUNCTION or SUBROUTINE statement at %L", &old_loc);
7160 15244 : }
7161 :
7162 :
7163 : /* The result variable in a MODULE PROCEDURE needs to be created and
7164 : its characteristics copied from the interface since it is neither
7165 : declared in the procedure declaration nor in the specification
7166 : part. */
7167 :
7168 : static void
7169 116 : get_modproc_result (void)
7170 : {
7171 116 : gfc_symbol *proc;
7172 116 : if (gfc_state_stack->previous
7173 116 : && gfc_state_stack->previous->state == COMP_CONTAINS
7174 116 : && gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
7175 : {
7176 84 : proc = gfc_current_ns->proc_name ? gfc_current_ns->proc_name : NULL;
7177 84 : if (proc != NULL
7178 84 : && proc->attr.function
7179 84 : && proc->tlink
7180 84 : && proc->tlink->result
7181 84 : && proc->tlink->result != proc->tlink)
7182 : {
7183 47 : gfc_copy_dummy_sym (&proc->result, proc->tlink->result, 1);
7184 47 : gfc_set_sym_referenced (proc->result);
7185 47 : proc->result->attr.if_source = IFSRC_DECL;
7186 47 : gfc_commit_symbol (proc->result);
7187 : }
7188 : }
7189 116 : }
7190 :
7191 :
7192 : /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
7193 :
7194 : static void
7195 77938 : parse_progunit (gfc_statement st)
7196 : {
7197 77938 : gfc_state_data *p;
7198 77938 : int n;
7199 :
7200 77938 : gfc_adjust_builtins ();
7201 :
7202 77938 : if (gfc_new_block
7203 69128 : && gfc_new_block->abr_modproc_decl
7204 264 : && gfc_new_block->attr.function)
7205 116 : get_modproc_result ();
7206 :
7207 77938 : st = parse_spec (st);
7208 77919 : switch (st)
7209 : {
7210 0 : case ST_NONE:
7211 0 : unexpected_eof ();
7212 :
7213 193 : case ST_CONTAINS:
7214 : /* This is not allowed within BLOCK! */
7215 193 : if (gfc_current_state () != COMP_BLOCK)
7216 192 : goto contains;
7217 : break;
7218 :
7219 4663 : case_end:
7220 4663 : accept_statement (st);
7221 4663 : goto done;
7222 :
7223 : default:
7224 : break;
7225 : }
7226 :
7227 73064 : if (gfc_current_state () == COMP_FUNCTION)
7228 13027 : gfc_check_function_type (gfc_current_ns);
7229 :
7230 60037 : loop:
7231 73307 : for (;;)
7232 : {
7233 73307 : st = parse_executable (st);
7234 :
7235 73281 : switch (st)
7236 : {
7237 0 : case ST_NONE:
7238 0 : unexpected_eof ();
7239 :
7240 7564 : case ST_CONTAINS:
7241 : /* This is not allowed within BLOCK! */
7242 7564 : if (gfc_current_state () != COMP_BLOCK)
7243 7562 : goto contains;
7244 : break;
7245 :
7246 65476 : case_end:
7247 65476 : accept_statement (st);
7248 65476 : goto done;
7249 :
7250 : /* Specification statements cannot appear after executable statements. */
7251 37 : case_decl:
7252 37 : case_omp_decl:
7253 37 : gfc_error ("%s statement at %C cannot appear after executable statements",
7254 : gfc_ascii_statement (st));
7255 37 : reject_statement ();
7256 37 : st = next_statement ();
7257 37 : continue;
7258 :
7259 : default:
7260 : break;
7261 : }
7262 :
7263 206 : unexpected_statement (st);
7264 206 : reject_statement ();
7265 206 : st = next_statement ();
7266 : }
7267 :
7268 7754 : contains:
7269 7754 : n = 0;
7270 :
7271 23858 : for (p = gfc_state_stack; p; p = p->previous)
7272 16104 : if (p->state == COMP_CONTAINS)
7273 298 : n++;
7274 :
7275 7754 : if (gfc_find_state (COMP_MODULE) == true
7276 7754 : || gfc_find_state (COMP_SUBMODULE) == true)
7277 298 : n--;
7278 :
7279 7754 : if (n > 0)
7280 : {
7281 0 : gfc_error ("CONTAINS statement at %C is already in a contained "
7282 : "program unit");
7283 0 : reject_statement ();
7284 0 : st = next_statement ();
7285 0 : goto loop;
7286 : }
7287 :
7288 7754 : parse_contained (0);
7289 :
7290 77891 : done:
7291 77891 : gfc_current_ns->code = gfc_state_stack->head;
7292 77891 : }
7293 :
7294 :
7295 : /* Come here to complain about a global symbol already in use as
7296 : something else. */
7297 :
7298 : void
7299 19 : gfc_global_used (gfc_gsymbol *sym, locus *where)
7300 : {
7301 19 : const char *name;
7302 :
7303 19 : if (where == NULL)
7304 0 : where = &gfc_current_locus;
7305 :
7306 19 : switch(sym->type)
7307 : {
7308 : case GSYM_PROGRAM:
7309 : name = "PROGRAM";
7310 : break;
7311 4 : case GSYM_FUNCTION:
7312 4 : name = "FUNCTION";
7313 4 : break;
7314 8 : case GSYM_SUBROUTINE:
7315 8 : name = "SUBROUTINE";
7316 8 : break;
7317 3 : case GSYM_COMMON:
7318 3 : name = "COMMON";
7319 3 : break;
7320 0 : case GSYM_BLOCK_DATA:
7321 0 : name = "BLOCK DATA";
7322 0 : break;
7323 2 : case GSYM_MODULE:
7324 2 : name = "MODULE";
7325 2 : break;
7326 1 : default:
7327 1 : name = NULL;
7328 : }
7329 :
7330 17 : if (name)
7331 : {
7332 18 : if (sym->binding_label)
7333 3 : gfc_error ("Global binding name %qs at %L is already being used "
7334 : "as a %s at %L", sym->binding_label, where, name,
7335 : &sym->where);
7336 : else
7337 15 : gfc_error ("Global name %qs at %L is already being used as "
7338 : "a %s at %L", sym->name, where, name, &sym->where);
7339 : }
7340 : else
7341 : {
7342 1 : if (sym->binding_label)
7343 1 : gfc_error ("Global binding name %qs at %L is already being used "
7344 : "at %L", sym->binding_label, where, &sym->where);
7345 : else
7346 0 : gfc_error ("Global name %qs at %L is already being used at %L",
7347 : sym->name, where, &sym->where);
7348 : }
7349 19 : }
7350 :
7351 :
7352 : /* Parse a block data program unit. */
7353 :
7354 : static void
7355 87 : parse_block_data (void)
7356 : {
7357 87 : gfc_statement st;
7358 87 : static locus blank_locus;
7359 87 : static int blank_block=0;
7360 87 : gfc_gsymbol *s;
7361 :
7362 87 : gfc_current_ns->proc_name = gfc_new_block;
7363 87 : gfc_current_ns->is_block_data = 1;
7364 :
7365 87 : if (gfc_new_block == NULL)
7366 : {
7367 49 : if (blank_block)
7368 0 : gfc_error ("Blank BLOCK DATA at %C conflicts with "
7369 : "prior BLOCK DATA at %L", &blank_locus);
7370 : else
7371 : {
7372 49 : blank_block = 1;
7373 49 : blank_locus = gfc_current_locus;
7374 : }
7375 : }
7376 : else
7377 : {
7378 38 : s = gfc_get_gsymbol (gfc_new_block->name, false);
7379 38 : if (s->defined
7380 38 : || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
7381 0 : gfc_global_used (s, &gfc_new_block->declared_at);
7382 : else
7383 : {
7384 38 : s->type = GSYM_BLOCK_DATA;
7385 38 : s->where = gfc_new_block->declared_at;
7386 38 : s->defined = 1;
7387 : }
7388 : }
7389 :
7390 87 : st = parse_spec (ST_NONE);
7391 :
7392 174 : while (st != ST_END_BLOCK_DATA)
7393 : {
7394 1 : gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
7395 : gfc_ascii_statement (st));
7396 1 : reject_statement ();
7397 1 : st = next_statement ();
7398 : }
7399 86 : }
7400 :
7401 :
7402 : /* Following the association of the ancestor (sub)module symbols, they
7403 : must be set host rather than use associated and all must be public.
7404 : They are flagged up by 'used_in_submodule' so that they can be set
7405 : DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
7406 : linker chokes on multiple symbol definitions. */
7407 :
7408 : static void
7409 2624 : set_syms_host_assoc (gfc_symbol *sym)
7410 : {
7411 2624 : gfc_component *c;
7412 2624 : const char dot[2] = ".";
7413 : /* Symbols take the form module.submodule_ or module.name_. */
7414 2624 : char parent1[2 * GFC_MAX_SYMBOL_LEN + 2];
7415 2624 : char parent2[2 * GFC_MAX_SYMBOL_LEN + 2];
7416 :
7417 2624 : if (sym == NULL)
7418 0 : return;
7419 :
7420 2624 : if (sym->attr.module_procedure)
7421 612 : sym->attr.external = 0;
7422 :
7423 2624 : sym->attr.use_assoc = 0;
7424 2624 : sym->attr.host_assoc = 1;
7425 2624 : sym->attr.used_in_submodule =1;
7426 :
7427 2624 : if (sym->attr.flavor == FL_DERIVED)
7428 : {
7429 : /* Derived types with PRIVATE components that are declared in
7430 : modules other than the parent module must not be changed to be
7431 : PUBLIC. The 'use-assoc' attribute must be reset so that the
7432 : test in symbol.cc(gfc_find_component) works correctly. This is
7433 : not necessary for PRIVATE symbols since they are not read from
7434 : the module. */
7435 503 : memset(parent1, '\0', sizeof(parent1));
7436 503 : memset(parent2, '\0', sizeof(parent2));
7437 503 : strcpy (parent1, gfc_new_block->name);
7438 503 : strcpy (parent2, sym->module);
7439 503 : if (strcmp (strtok (parent1, dot), strtok (parent2, dot)) == 0)
7440 : {
7441 2305 : for (c = sym->components; c; c = c->next)
7442 1851 : c->attr.access = ACCESS_PUBLIC;
7443 : }
7444 : else
7445 : {
7446 49 : sym->attr.use_assoc = 1;
7447 49 : sym->attr.host_assoc = 0;
7448 : }
7449 : }
7450 : }
7451 :
7452 : /* Parse a module subprogram. */
7453 :
7454 : static void
7455 10166 : parse_module (void)
7456 : {
7457 10166 : gfc_statement st;
7458 10166 : gfc_gsymbol *s;
7459 :
7460 10166 : s = gfc_get_gsymbol (gfc_new_block->name, false);
7461 10166 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
7462 1 : gfc_global_used (s, &gfc_new_block->declared_at);
7463 : else
7464 : {
7465 10165 : s->type = GSYM_MODULE;
7466 10165 : s->where = gfc_new_block->declared_at;
7467 10165 : s->defined = 1;
7468 : }
7469 :
7470 : /* Something is nulling the module_list after this point. This is good
7471 : since it allows us to 'USE' the parent modules that the submodule
7472 : inherits and to set (most) of the symbols as host associated. */
7473 10166 : if (gfc_current_state () == COMP_SUBMODULE)
7474 : {
7475 265 : use_modules ();
7476 264 : gfc_traverse_ns (gfc_current_ns, set_syms_host_assoc);
7477 :
7478 : /* Link the submodule namespace to the parent (sub)module namespace so
7479 : that internal subprograms of the ancestor module are accessible via
7480 : host association (Fortran 2018, 14.6.1.3). The parent namespace is
7481 : already in gfc_global_ns_list when both units are compiled together.
7482 : The submodule's fully-qualified name is "parent.child"; strip the
7483 : child part to obtain the parent's name, then search the global list. */
7484 264 : {
7485 264 : const char *submod_name = gfc_new_block->name;
7486 264 : const char *dot = strrchr (submod_name, '.');
7487 264 : if (dot != NULL)
7488 : {
7489 264 : size_t plen = (size_t) (dot - submod_name);
7490 264 : char parent_name[GFC_MAX_SYMBOL_LEN + 1];
7491 264 : gcc_assert (plen < sizeof (parent_name));
7492 264 : memcpy (parent_name, submod_name, plen);
7493 264 : parent_name[plen] = '\0';
7494 356 : for (gfc_namespace *ns = gfc_global_ns_list; ns; ns = ns->sibling)
7495 335 : if (ns->proc_name
7496 335 : && strcmp (ns->proc_name->name, parent_name) == 0)
7497 : {
7498 243 : gfc_current_ns->parent = ns;
7499 243 : break;
7500 : }
7501 : }
7502 : }
7503 : }
7504 :
7505 10165 : st = parse_spec (ST_NONE);
7506 :
7507 10167 : loop:
7508 10167 : switch (st)
7509 : {
7510 0 : case ST_NONE:
7511 0 : unexpected_eof ();
7512 :
7513 7493 : case ST_CONTAINS:
7514 7493 : parse_contained (1);
7515 7493 : break;
7516 :
7517 2671 : case ST_END_MODULE:
7518 2671 : case ST_END_SUBMODULE:
7519 2671 : accept_statement (st);
7520 2671 : break;
7521 :
7522 3 : default:
7523 3 : gfc_error ("Unexpected %s statement in MODULE at %C",
7524 : gfc_ascii_statement (st));
7525 3 : reject_statement ();
7526 3 : st = next_statement ();
7527 3 : goto loop;
7528 : }
7529 10163 : s->ns = gfc_current_ns;
7530 10163 : }
7531 :
7532 :
7533 : /* Add a procedure name to the global symbol table. */
7534 :
7535 : static void
7536 11738 : add_global_procedure (bool sub)
7537 : {
7538 11738 : gfc_gsymbol *s;
7539 :
7540 : /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7541 : name is a global identifier. */
7542 11738 : if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008))
7543 : {
7544 11332 : s = gfc_get_gsymbol (gfc_new_block->name, false);
7545 :
7546 11332 : if (s->defined
7547 11330 : || (s->type != GSYM_UNKNOWN
7548 100 : && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
7549 : {
7550 2 : gfc_global_used (s, &gfc_new_block->declared_at);
7551 : /* Silence follow-up errors. */
7552 2 : gfc_new_block->binding_label = NULL;
7553 : }
7554 : else
7555 : {
7556 11330 : s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
7557 11330 : s->sym_name = gfc_new_block->name;
7558 11330 : s->where = gfc_new_block->declared_at;
7559 11330 : s->defined = 1;
7560 11330 : s->ns = gfc_current_ns;
7561 : }
7562 : }
7563 :
7564 : /* Don't add the symbol multiple times. */
7565 11738 : if (gfc_new_block->binding_label
7566 11738 : && (!gfc_notification_std (GFC_STD_F2008)
7567 59 : || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0))
7568 : {
7569 407 : s = gfc_get_gsymbol (gfc_new_block->binding_label, true);
7570 :
7571 407 : if (s->defined
7572 404 : || (s->type != GSYM_UNKNOWN
7573 5 : && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
7574 : {
7575 3 : gfc_global_used (s, &gfc_new_block->declared_at);
7576 : /* Silence follow-up errors. */
7577 3 : gfc_new_block->binding_label = NULL;
7578 : }
7579 : else
7580 : {
7581 404 : s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
7582 404 : s->sym_name = gfc_new_block->name;
7583 404 : s->binding_label = gfc_new_block->binding_label;
7584 404 : s->where = gfc_new_block->declared_at;
7585 404 : s->defined = 1;
7586 404 : s->ns = gfc_current_ns;
7587 : }
7588 : }
7589 11738 : }
7590 :
7591 :
7592 : /* Add a program to the global symbol table. */
7593 :
7594 : static void
7595 19381 : add_global_program (void)
7596 : {
7597 19381 : gfc_gsymbol *s;
7598 :
7599 19381 : if (gfc_new_block == NULL)
7600 : return;
7601 19381 : s = gfc_get_gsymbol (gfc_new_block->name, false);
7602 :
7603 19381 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
7604 0 : gfc_global_used (s, &gfc_new_block->declared_at);
7605 : else
7606 : {
7607 19381 : s->type = GSYM_PROGRAM;
7608 19381 : s->where = gfc_new_block->declared_at;
7609 19381 : s->defined = 1;
7610 19381 : s->ns = gfc_current_ns;
7611 : }
7612 : }
7613 :
7614 : /* Rewrite expression where needed.
7615 : - Currently this is done for co-indexed expressions only.
7616 : */
7617 : static void
7618 469 : rewrite_expr_tree (gfc_namespace *gfc_global_ns_list)
7619 : {
7620 996 : for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
7621 527 : gfc_current_ns = gfc_current_ns->sibling)
7622 527 : gfc_coarray_rewrite (gfc_current_ns);
7623 469 : }
7624 :
7625 : /* Resolve all the program units. */
7626 : static void
7627 31919 : resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
7628 : {
7629 31919 : gfc_derived_types = NULL;
7630 31919 : gfc_current_ns = gfc_global_ns_list;
7631 79124 : for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
7632 : {
7633 47206 : if (gfc_current_ns->proc_name
7634 47206 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
7635 10153 : continue; /* Already resolved. */
7636 :
7637 37053 : if (gfc_current_ns->proc_name)
7638 37053 : gfc_current_locus = gfc_current_ns->proc_name->declared_at;
7639 37053 : gfc_resolve (gfc_current_ns);
7640 37052 : gfc_current_ns->derived_types = gfc_derived_types;
7641 37052 : gfc_derived_types = NULL;
7642 : }
7643 31918 : }
7644 :
7645 :
7646 : static void
7647 221210 : clean_up_modules (gfc_gsymbol *&gsym)
7648 : {
7649 221210 : if (gsym == NULL)
7650 : return;
7651 :
7652 94646 : clean_up_modules (gsym->left);
7653 94646 : clean_up_modules (gsym->right);
7654 :
7655 94646 : if (gsym->type != GSYM_MODULE)
7656 : return;
7657 :
7658 10542 : if (gsym->ns)
7659 : {
7660 10542 : gfc_current_ns = gsym->ns;
7661 : /* Disconnect any host-association parent link set for submodules
7662 : (see parse_module): each module/submodule namespace in gfc_gsym_root
7663 : is independently managed, so gfc_symbol_done_2 must not walk up to
7664 : and double-free a sibling top-level namespace. */
7665 10542 : gfc_current_ns->parent = NULL;
7666 10542 : gfc_derived_types = gfc_current_ns->derived_types;
7667 10542 : gfc_done_2 ();
7668 10542 : gsym->ns = NULL;
7669 : }
7670 10542 : free (gsym);
7671 10542 : gsym = NULL;
7672 : }
7673 :
7674 :
7675 : /* Translate all the program units. This could be in a different order
7676 : to resolution if there are forward references in the file. */
7677 : static void
7678 31918 : translate_all_program_units (gfc_namespace *gfc_global_ns_list)
7679 : {
7680 31918 : int errors;
7681 :
7682 31918 : gfc_current_ns = gfc_global_ns_list;
7683 31918 : gfc_get_errors (NULL, &errors);
7684 :
7685 : /* We first translate all modules to make sure that later parts
7686 : of the program can use the decl. Then we translate the nonmodules. */
7687 :
7688 109843 : for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
7689 : {
7690 46007 : if (!gfc_current_ns->proc_name
7691 46007 : || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
7692 36694 : continue;
7693 :
7694 9313 : gfc_current_locus = gfc_current_ns->proc_name->declared_at;
7695 9313 : gfc_derived_types = gfc_current_ns->derived_types;
7696 9313 : gfc_generate_module_code (gfc_current_ns);
7697 9313 : gfc_current_ns->translated = 1;
7698 : }
7699 :
7700 31918 : gfc_current_ns = gfc_global_ns_list;
7701 77925 : for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
7702 : {
7703 46007 : if (gfc_current_ns->proc_name
7704 46007 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
7705 9313 : continue;
7706 :
7707 36694 : gfc_current_locus = gfc_current_ns->proc_name->declared_at;
7708 36694 : gfc_derived_types = gfc_current_ns->derived_types;
7709 36694 : gfc_generate_code (gfc_current_ns);
7710 36694 : gfc_current_ns->translated = 1;
7711 : }
7712 :
7713 : /* Clean up all the namespaces after translation. */
7714 31918 : gfc_current_ns = gfc_global_ns_list;
7715 81813 : for (;gfc_current_ns;)
7716 : {
7717 49895 : gfc_namespace *ns;
7718 :
7719 49895 : if (gfc_current_ns->proc_name
7720 49895 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
7721 : {
7722 10153 : gfc_current_ns = gfc_current_ns->sibling;
7723 10153 : continue;
7724 : }
7725 :
7726 39742 : ns = gfc_current_ns->sibling;
7727 39742 : gfc_derived_types = gfc_current_ns->derived_types;
7728 39742 : gfc_done_2 ();
7729 39742 : gfc_current_ns = ns;
7730 : }
7731 :
7732 31918 : clean_up_modules (gfc_gsym_root);
7733 31918 : }
7734 :
7735 :
7736 : /* Top level parser. */
7737 :
7738 : bool
7739 31964 : gfc_parse_file (void)
7740 : {
7741 31964 : int seen_program, errors_before, errors;
7742 31964 : gfc_state_data top, s;
7743 31964 : gfc_statement st;
7744 31964 : locus prog_locus;
7745 31964 : gfc_namespace *next;
7746 :
7747 31964 : gfc_start_source_files ();
7748 :
7749 31964 : top.state = COMP_NONE;
7750 31964 : top.sym = NULL;
7751 31964 : top.previous = NULL;
7752 31964 : top.head = top.tail = NULL;
7753 31964 : top.do_variable = NULL;
7754 :
7755 31964 : gfc_state_stack = ⊤
7756 :
7757 31964 : gfc_clear_new_st ();
7758 :
7759 31964 : gfc_statement_label = NULL;
7760 :
7761 31964 : gfc_omp_metadirective_region_count = 0;
7762 31964 : gfc_omp_metadirective_region_stack.truncate (0);
7763 31964 : gfc_omp_metadirective_region_stack.safe_push (0);
7764 31964 : gfc_in_omp_metadirective_body = false;
7765 31964 : gfc_matching_omp_context_selector = false;
7766 :
7767 31997 : if (setjmp (eof_buf))
7768 : return false; /* Come here on unexpected EOF */
7769 :
7770 : /* Prepare the global namespace that will contain the
7771 : program units. */
7772 31964 : gfc_global_ns_list = next = NULL;
7773 :
7774 31964 : seen_program = 0;
7775 31964 : errors_before = 0;
7776 :
7777 : /* Exit early for empty files. */
7778 31964 : if (gfc_at_eof ())
7779 0 : goto done;
7780 :
7781 31964 : in_specification_block = true;
7782 81961 : loop:
7783 81961 : gfc_init_2 ();
7784 81961 : st = next_statement ();
7785 81958 : switch (st)
7786 : {
7787 31919 : case ST_NONE:
7788 31919 : gfc_done_2 ();
7789 31919 : goto done;
7790 :
7791 19382 : case ST_PROGRAM:
7792 19382 : if (seen_program)
7793 1 : goto duplicate_main;
7794 19381 : seen_program = 1;
7795 19381 : prog_locus = gfc_current_locus;
7796 :
7797 19381 : push_state (&s, COMP_PROGRAM, gfc_new_block);
7798 19381 : main_program_symbol (gfc_current_ns, gfc_new_block->name);
7799 19381 : accept_statement (st);
7800 19381 : add_global_program ();
7801 19381 : parse_progunit (ST_NONE);
7802 19362 : goto prog_units;
7803 :
7804 8757 : case ST_SUBROUTINE:
7805 8757 : add_global_procedure (true);
7806 8757 : push_state (&s, COMP_SUBROUTINE, gfc_new_block);
7807 8757 : accept_statement (st);
7808 8757 : parse_progunit (ST_NONE);
7809 8752 : goto prog_units;
7810 :
7811 2981 : case ST_FUNCTION:
7812 2981 : add_global_procedure (false);
7813 2981 : push_state (&s, COMP_FUNCTION, gfc_new_block);
7814 2981 : accept_statement (st);
7815 2981 : parse_progunit (ST_NONE);
7816 2981 : goto prog_units;
7817 :
7818 87 : case ST_BLOCK_DATA:
7819 87 : push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
7820 87 : accept_statement (st);
7821 87 : parse_block_data ();
7822 : break;
7823 :
7824 9901 : case ST_MODULE:
7825 9901 : push_state (&s, COMP_MODULE, gfc_new_block);
7826 9901 : accept_statement (st);
7827 :
7828 9901 : gfc_get_errors (NULL, &errors_before);
7829 9901 : parse_module ();
7830 : break;
7831 :
7832 265 : case ST_SUBMODULE:
7833 265 : push_state (&s, COMP_SUBMODULE, gfc_new_block);
7834 265 : accept_statement (st);
7835 :
7836 265 : gfc_get_errors (NULL, &errors_before);
7837 265 : parse_module ();
7838 : break;
7839 :
7840 : /* Anything else starts a nameless main program block. */
7841 8666 : default:
7842 8666 : if (seen_program)
7843 1 : goto duplicate_main;
7844 8665 : seen_program = 1;
7845 8665 : prog_locus = gfc_current_locus;
7846 :
7847 8665 : push_state (&s, COMP_PROGRAM, gfc_new_block);
7848 8665 : main_program_symbol (gfc_current_ns, "MAIN__");
7849 8665 : parse_progunit (st);
7850 8653 : goto prog_units;
7851 : }
7852 :
7853 : /* Handle the non-program units. */
7854 10249 : gfc_current_ns->code = s.head;
7855 :
7856 10249 : gfc_resolve (gfc_current_ns);
7857 :
7858 : /* Fix the implicit_pure attribute for those procedures who should
7859 : not have it. */
7860 10350 : while (gfc_fix_implicit_pure (gfc_current_ns))
7861 : ;
7862 :
7863 : /* Dump the parse tree if requested. */
7864 10249 : if (flag_dump_fortran_original)
7865 0 : gfc_dump_parse_tree (gfc_current_ns, stdout);
7866 :
7867 10249 : gfc_get_errors (NULL, &errors);
7868 10249 : if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE)
7869 : {
7870 10163 : gfc_dump_module (s.sym->name, errors_before == errors);
7871 10163 : gfc_current_ns->derived_types = gfc_derived_types;
7872 10163 : gfc_derived_types = NULL;
7873 10163 : goto prog_units;
7874 : }
7875 : else
7876 : {
7877 86 : if (errors == 0)
7878 72 : gfc_generate_code (gfc_current_ns);
7879 86 : pop_state ();
7880 86 : gfc_done_2 ();
7881 : }
7882 :
7883 86 : goto loop;
7884 :
7885 49911 : prog_units:
7886 : /* The main program and non-contained procedures are put
7887 : in the global namespace list, so that they can be processed
7888 : later and all their interfaces resolved. */
7889 49911 : gfc_current_ns->code = s.head;
7890 49911 : if (next)
7891 : {
7892 18151 : for (; next->sibling; next = next->sibling)
7893 : ;
7894 18140 : next->sibling = gfc_current_ns;
7895 : }
7896 : else
7897 31771 : gfc_global_ns_list = gfc_current_ns;
7898 :
7899 49911 : next = gfc_current_ns;
7900 :
7901 49911 : pop_state ();
7902 49911 : goto loop;
7903 :
7904 31919 : done:
7905 : /* Do the resolution. */
7906 31919 : resolve_all_program_units (gfc_global_ns_list);
7907 :
7908 31918 : if (flag_coarray == GFC_FCOARRAY_LIB)
7909 469 : rewrite_expr_tree (gfc_global_ns_list);
7910 :
7911 : /* Go through all top-level namespaces and unset the implicit_pure
7912 : attribute for any procedures that call something not pure or
7913 : implicit_pure. Because the a procedure marked as not implicit_pure
7914 : in one sweep may be called by another routine, we repeat this
7915 : process until there are no more changes. */
7916 31937 : bool changed;
7917 31937 : do
7918 : {
7919 31937 : changed = false;
7920 81857 : for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
7921 49920 : gfc_current_ns = gfc_current_ns->sibling)
7922 : {
7923 49920 : if (gfc_fix_implicit_pure (gfc_current_ns))
7924 19 : changed = true;
7925 : }
7926 : }
7927 : while (changed);
7928 :
7929 : /* Fixup for external procedures and resolve 'omp requires'. */
7930 31918 : int omp_requires;
7931 31918 : bool omp_target_seen;
7932 31918 : omp_requires = 0;
7933 31918 : omp_target_seen = false;
7934 81813 : for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
7935 49895 : gfc_current_ns = gfc_current_ns->sibling)
7936 : {
7937 49895 : omp_requires |= gfc_current_ns->omp_requires;
7938 49895 : omp_target_seen |= gfc_current_ns->omp_target_seen;
7939 49895 : gfc_check_externals (gfc_current_ns);
7940 : }
7941 81813 : for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
7942 49895 : gfc_current_ns = gfc_current_ns->sibling)
7943 49895 : gfc_check_omp_requires (gfc_current_ns, omp_requires);
7944 :
7945 : /* Populate omp_requires_mask (needed for resolving OpenMP
7946 : metadirectives and declare variant). */
7947 31918 : switch (omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
7948 : {
7949 6 : case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
7950 6 : omp_requires_mask
7951 6 : = (enum omp_requires) (omp_requires_mask
7952 : | int (OMP_MEMORY_ORDER_SEQ_CST));
7953 6 : break;
7954 3 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
7955 3 : omp_requires_mask
7956 3 : = (enum omp_requires) (omp_requires_mask
7957 : | int (OMP_MEMORY_ORDER_ACQ_REL));
7958 3 : break;
7959 1 : case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE:
7960 1 : omp_requires_mask
7961 1 : = (enum omp_requires) (omp_requires_mask
7962 : | int (OMP_MEMORY_ORDER_ACQUIRE));
7963 1 : break;
7964 4 : case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
7965 4 : omp_requires_mask
7966 4 : = (enum omp_requires) (omp_requires_mask
7967 : | int (OMP_MEMORY_ORDER_RELAXED));
7968 4 : break;
7969 2 : case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE:
7970 2 : omp_requires_mask
7971 2 : = (enum omp_requires) (omp_requires_mask
7972 : | int (OMP_MEMORY_ORDER_RELEASE));
7973 2 : break;
7974 : }
7975 :
7976 31918 : if (omp_target_seen)
7977 1003 : omp_requires_mask = (enum omp_requires) (omp_requires_mask
7978 : | int (OMP_REQUIRES_TARGET_USED));
7979 31918 : if (omp_requires & OMP_REQ_REVERSE_OFFLOAD)
7980 23 : omp_requires_mask
7981 23 : = (enum omp_requires) (omp_requires_mask
7982 : | int (OMP_REQUIRES_REVERSE_OFFLOAD));
7983 31918 : if (omp_requires & OMP_REQ_UNIFIED_ADDRESS)
7984 4 : omp_requires_mask
7985 4 : = (enum omp_requires) (omp_requires_mask
7986 : | int (OMP_REQUIRES_UNIFIED_ADDRESS));
7987 31918 : if (omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
7988 6 : omp_requires_mask
7989 6 : = (enum omp_requires) (omp_requires_mask
7990 : | int (OMP_REQUIRES_UNIFIED_SHARED_MEMORY));
7991 31918 : if (omp_requires & OMP_REQ_SELF_MAPS)
7992 8 : omp_requires_mask
7993 8 : = (enum omp_requires) (omp_requires_mask | int (OMP_REQUIRES_SELF_MAPS));
7994 31918 : if (omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
7995 5 : omp_requires_mask
7996 5 : = (enum omp_requires) (omp_requires_mask
7997 : | int (OMP_REQUIRES_DYNAMIC_ALLOCATORS));
7998 : /* Do the parse tree dump. */
7999 31918 : gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL;
8000 :
8001 31958 : for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
8002 40 : if (!gfc_current_ns->proc_name
8003 40 : || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
8004 : {
8005 40 : gfc_dump_parse_tree (gfc_current_ns, stdout);
8006 40 : fputs ("------------------------------------------\n\n", stdout);
8007 : }
8008 :
8009 : /* Dump C prototypes. */
8010 31918 : if (flag_c_prototypes || flag_c_prototypes_external)
8011 : {
8012 2 : fprintf (stdout,
8013 : "#include <stddef.h>\n"
8014 : "#ifdef __cplusplus\n"
8015 : "#include <complex>\n"
8016 : "#define __GFORTRAN_FLOAT_COMPLEX std::complex<float>\n"
8017 : "#define __GFORTRAN_DOUBLE_COMPLEX std::complex<double>\n"
8018 : "#define __GFORTRAN_LONG_DOUBLE_COMPLEX std::complex<long double>\n"
8019 : "extern \"C\" {\n"
8020 : "#else\n"
8021 : "#define __GFORTRAN_FLOAT_COMPLEX float _Complex\n"
8022 : "#define __GFORTRAN_DOUBLE_COMPLEX double _Complex\n"
8023 : "#define __GFORTRAN_LONG_DOUBLE_COMPLEX long double _Complex\n"
8024 : "#endif\n\n");
8025 : }
8026 :
8027 : /* First dump BIND(C) prototypes. */
8028 31918 : if (flag_c_prototypes)
8029 2 : gfc_dump_c_prototypes (stdout);
8030 :
8031 : /* Dump external prototypes. */
8032 31918 : if (flag_c_prototypes_external)
8033 0 : gfc_dump_external_c_prototypes (stdout);
8034 :
8035 31918 : if (flag_c_prototypes || flag_c_prototypes_external)
8036 2 : fprintf (stdout, "\n#ifdef __cplusplus\n}\n#endif\n");
8037 :
8038 : /* Do the translation. */
8039 31918 : translate_all_program_units (gfc_global_ns_list);
8040 :
8041 : /* Dump the global symbol ist. We only do this here because part
8042 : of it is generated after mangling the identifiers in
8043 : trans-decl.cc. */
8044 :
8045 31918 : if (flag_dump_fortran_global)
8046 0 : gfc_dump_global_symbols (stdout);
8047 :
8048 31918 : gfc_end_source_files ();
8049 : return true;
8050 :
8051 2 : duplicate_main:
8052 : /* If we see a duplicate main program, shut down. If the second
8053 : instance is an implied main program, i.e. data decls or executable
8054 : statements, we're in for lots of errors. */
8055 2 : gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
8056 2 : reject_statement ();
8057 2 : gfc_done_2 ();
8058 : return true;
8059 : }
8060 :
8061 : /* Return true if this state data represents an OpenACC region. */
8062 : bool
8063 7 : is_oacc (gfc_state_data *sd)
8064 : {
8065 7 : switch (sd->construct->op)
8066 : {
8067 : case EXEC_OACC_PARALLEL_LOOP:
8068 : case EXEC_OACC_PARALLEL:
8069 : case EXEC_OACC_KERNELS_LOOP:
8070 : case EXEC_OACC_KERNELS:
8071 : case EXEC_OACC_SERIAL_LOOP:
8072 : case EXEC_OACC_SERIAL:
8073 : case EXEC_OACC_DATA:
8074 : case EXEC_OACC_HOST_DATA:
8075 : case EXEC_OACC_LOOP:
8076 : case EXEC_OACC_UPDATE:
8077 : case EXEC_OACC_WAIT:
8078 : case EXEC_OACC_CACHE:
8079 : case EXEC_OACC_ENTER_DATA:
8080 : case EXEC_OACC_EXIT_DATA:
8081 : case EXEC_OACC_ATOMIC:
8082 : case EXEC_OACC_ROUTINE:
8083 : case EXEC_OACC_INIT:
8084 : case EXEC_OACC_SHUTDOWN:
8085 : case EXEC_OACC_SET:
8086 : return true;
8087 :
8088 3 : default:
8089 3 : return false;
8090 : }
8091 : }
8092 :
8093 : /* Return true if ST is a declarative OpenMP statement. */
8094 : bool
8095 253 : is_omp_declarative_stmt (gfc_statement st)
8096 : {
8097 253 : switch (st)
8098 : {
8099 : case_omp_decl:
8100 : return true;
8101 253 : default:
8102 253 : return false;
8103 : }
8104 : }
|
