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