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