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