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