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