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