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