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