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