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