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