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