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