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