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