2 Copyright (C) 2000-2014 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
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
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
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/>. */
24 #include "coretypes.h"
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. */
33 gfc_st_label
*gfc_statement_label
;
35 static locus label_locus
;
36 static jmp_buf eof_buf
;
38 gfc_state_data
*gfc_state_stack
;
39 static bool last_was_use_stmt
= false;
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);
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
54 match_word (const char *str
, match (*subr
) (void), locus
*old_locus
)
69 gfc_current_locus
= *old_locus
;
77 /* Like match_word, but if str is matched, set a flag that it
80 match_word_omp_simd (const char *str
, match (*subr
) (void), locus
*old_locus
,
97 gfc_current_locus
= *old_locus
;
105 /* Load symbols from all USE statements encountered in this scoping unit. */
110 gfc_error_buf old_error
;
112 gfc_push_error (&old_error
);
113 gfc_buffer_error (0);
115 gfc_buffer_error (1);
116 gfc_pop_error (&old_error
);
117 gfc_commit_symbols ();
118 gfc_warning_check ();
119 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
120 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
121 last_was_use_stmt
= false;
125 /* Figure out what the next statement is, (mostly) regardless of
126 proper ordering. The do...while(0) is there to prevent if/else
129 #define match(keyword, subr, st) \
131 if (match_word (keyword, subr, &old_locus) == MATCH_YES) \
134 undo_new_statement (); \
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. */
148 decode_specification_statement (void)
154 if (gfc_match_eos () == MATCH_YES
)
157 old_locus
= gfc_current_locus
;
159 if (match_word ("use", gfc_match_use
, &old_locus
) == MATCH_YES
)
161 last_was_use_stmt
= true;
166 undo_new_statement ();
167 if (last_was_use_stmt
)
171 match ("import", gfc_match_import
, ST_IMPORT
);
173 if (gfc_current_block ()->result
->ts
.type
!= BT_DERIVED
)
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
);
180 /* General statement matching: Instead of testing every possible
181 statement, we eliminate most possibilities by peeking at the
184 c
= gfc_peek_ascii_char ();
189 match ("abstract% interface", gfc_match_abstract_interface
,
191 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
192 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
196 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
200 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
201 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
205 match ("data", gfc_match_data
, ST_DATA
);
206 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
210 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
211 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
212 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
213 match ("external", gfc_match_external
, ST_ATTR_DECL
);
217 match ("format", gfc_match_format
, ST_FORMAT
);
224 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
225 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
226 match ("interface", gfc_match_interface
, ST_INTERFACE
);
227 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
228 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
235 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
239 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
243 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
244 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
245 if (gfc_match_private (&st
) == MATCH_YES
)
247 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
248 if (gfc_match_public (&st
) == MATCH_YES
)
250 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
257 match ("save", gfc_match_save
, ST_ATTR_DECL
);
261 match ("target", gfc_match_target
, ST_ATTR_DECL
);
262 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
269 match ("value", gfc_match_value
, ST_ATTR_DECL
);
270 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
277 /* This is not a specification statement. See if any of the matchers
278 has stored an error message of some sort. */
282 gfc_buffer_error (0);
283 gfc_current_locus
= old_locus
;
285 return ST_GET_FCN_CHARACTERISTICS
;
289 /* This is the primary 'decode_statement'. */
291 decode_statement (void)
299 gfc_enforce_clean_symbol_state ();
301 gfc_clear_error (); /* Clear any pending errors. */
302 gfc_clear_warning (); /* Clear any pending warnings. */
304 gfc_matching_function
= false;
306 if (gfc_match_eos () == MATCH_YES
)
309 if (gfc_current_state () == COMP_FUNCTION
310 && gfc_current_block ()->result
->ts
.kind
== -1)
311 return decode_specification_statement ();
313 old_locus
= gfc_current_locus
;
315 c
= gfc_peek_ascii_char ();
319 if (match_word ("use", gfc_match_use
, &old_locus
) == MATCH_YES
)
321 last_was_use_stmt
= true;
325 undo_new_statement ();
328 if (last_was_use_stmt
)
331 /* Try matching a data declaration or function declaration. The
332 input "REALFUNCTIONA(N)" can mean several things in different
333 contexts, so it (and its relatives) get special treatment. */
335 if (gfc_current_state () == COMP_NONE
336 || gfc_current_state () == COMP_INTERFACE
337 || gfc_current_state () == COMP_CONTAINS
)
339 gfc_matching_function
= true;
340 m
= gfc_match_function_decl ();
343 else if (m
== MATCH_ERROR
)
347 gfc_current_locus
= old_locus
;
349 gfc_matching_function
= false;
352 /* Match statements whose error messages are meant to be overwritten
353 by something better. */
355 match (NULL
, gfc_match_assignment
, ST_ASSIGNMENT
);
356 match (NULL
, gfc_match_pointer_assignment
, ST_POINTER_ASSIGNMENT
);
357 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
359 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
360 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
362 /* Try to match a subroutine statement, which has the same optional
363 prefixes that functions can have. */
365 if (gfc_match_subroutine () == MATCH_YES
)
366 return ST_SUBROUTINE
;
368 gfc_current_locus
= old_locus
;
370 /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
371 statements, which might begin with a block label. The match functions for
372 these statements are unusual in that their keyword is not seen before
373 the matcher is called. */
375 if (gfc_match_if (&st
) == MATCH_YES
)
378 gfc_current_locus
= old_locus
;
380 if (gfc_match_where (&st
) == MATCH_YES
)
383 gfc_current_locus
= old_locus
;
385 if (gfc_match_forall (&st
) == MATCH_YES
)
388 gfc_current_locus
= old_locus
;
390 match (NULL
, gfc_match_do
, ST_DO
);
391 match (NULL
, gfc_match_block
, ST_BLOCK
);
392 match (NULL
, gfc_match_associate
, ST_ASSOCIATE
);
393 match (NULL
, gfc_match_critical
, ST_CRITICAL
);
394 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
396 gfc_current_ns
= gfc_build_block_ns (gfc_current_ns
);
397 match (NULL
, gfc_match_select_type
, ST_SELECT_TYPE
);
399 gfc_current_ns
= gfc_current_ns
->parent
;
400 gfc_free_namespace (ns
);
402 /* General statement matching: Instead of testing every possible
403 statement, we eliminate most possibilities by peeking at the
409 match ("abstract% interface", gfc_match_abstract_interface
,
411 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
412 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
413 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
414 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
418 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
419 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
420 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
424 match ("call", gfc_match_call
, ST_CALL
);
425 match ("close", gfc_match_close
, ST_CLOSE
);
426 match ("continue", gfc_match_continue
, ST_CONTINUE
);
427 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
428 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
429 match ("case", gfc_match_case
, ST_CASE
);
430 match ("common", gfc_match_common
, ST_COMMON
);
431 match ("contains", gfc_match_eos
, ST_CONTAINS
);
432 match ("class", gfc_match_class_is
, ST_CLASS_IS
);
433 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
437 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
438 match ("data", gfc_match_data
, ST_DATA
);
439 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
443 match ("end file", gfc_match_endfile
, ST_END_FILE
);
444 match ("exit", gfc_match_exit
, ST_EXIT
);
445 match ("else", gfc_match_else
, ST_ELSE
);
446 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
447 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
448 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
);
449 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
451 if (gfc_match_end (&st
) == MATCH_YES
)
454 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
455 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
456 match ("external", gfc_match_external
, ST_ATTR_DECL
);
460 match ("final", gfc_match_final_decl
, ST_FINAL
);
461 match ("flush", gfc_match_flush
, ST_FLUSH
);
462 match ("format", gfc_match_format
, ST_FORMAT
);
466 match ("generic", gfc_match_generic
, ST_GENERIC
);
467 match ("go to", gfc_match_goto
, ST_GOTO
);
471 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
472 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
473 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
474 match ("import", gfc_match_import
, ST_IMPORT
);
475 match ("interface", gfc_match_interface
, ST_INTERFACE
);
476 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
477 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
481 match ("lock", gfc_match_lock
, ST_LOCK
);
485 match ("module% procedure", gfc_match_modproc
, ST_MODULE_PROC
);
486 match ("module", gfc_match_module
, ST_MODULE
);
490 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
491 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
495 match ("open", gfc_match_open
, ST_OPEN
);
496 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
500 match ("print", gfc_match_print
, ST_WRITE
);
501 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
502 match ("pause", gfc_match_pause
, ST_PAUSE
);
503 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
504 if (gfc_match_private (&st
) == MATCH_YES
)
506 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
507 match ("program", gfc_match_program
, ST_PROGRAM
);
508 if (gfc_match_public (&st
) == MATCH_YES
)
510 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
514 match ("read", gfc_match_read
, ST_READ
);
515 match ("return", gfc_match_return
, ST_RETURN
);
516 match ("rewind", gfc_match_rewind
, ST_REWIND
);
520 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
521 match ("stop", gfc_match_stop
, ST_STOP
);
522 match ("save", gfc_match_save
, ST_ATTR_DECL
);
523 match ("sync all", gfc_match_sync_all
, ST_SYNC_ALL
);
524 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
525 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
529 match ("target", gfc_match_target
, ST_ATTR_DECL
);
530 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
531 match ("type is", gfc_match_type_is
, ST_TYPE_IS
);
535 match ("unlock", gfc_match_unlock
, ST_UNLOCK
);
539 match ("value", gfc_match_value
, ST_ATTR_DECL
);
540 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
544 match ("wait", gfc_match_wait
, ST_WAIT
);
545 match ("write", gfc_match_write
, ST_WRITE
);
549 /* All else has failed, so give up. See if any of the matchers has
550 stored an error message of some sort. */
552 if (gfc_error_check () == 0)
553 gfc_error_now_2 ("Unclassifiable statement at %C");
557 gfc_error_recovery ();
562 /* Like match, but set a flag simd_matched if keyword matched. */
563 #define matchs(keyword, subr, st) \
565 if (match_word_omp_simd (keyword, subr, &old_locus, \
566 &simd_matched) == MATCH_YES) \
569 undo_new_statement (); \
572 /* Like match, but don't match anything if not -fopenmp. */
573 #define matcho(keyword, subr, st) \
575 if (!gfc_option.gfc_flag_openmp) \
577 else if (match_word (keyword, subr, &old_locus) \
581 undo_new_statement (); \
585 decode_oacc_directive (void)
590 gfc_enforce_clean_symbol_state ();
592 gfc_clear_error (); /* Clear any pending errors. */
593 gfc_clear_warning (); /* Clear any pending warnings. */
597 gfc_error_now ("OpenACC directives at %C may not appear in PURE "
599 gfc_error_recovery ();
603 gfc_unset_implicit_pure (NULL
);
605 old_locus
= gfc_current_locus
;
607 /* General OpenACC directive matching: Instead of testing every possible
608 statement, we eliminate most possibilities by peeking at the
611 c
= gfc_peek_ascii_char ();
616 match ("cache", gfc_match_oacc_cache
, ST_OACC_CACHE
);
619 match ("data", gfc_match_oacc_data
, ST_OACC_DATA
);
620 match ("declare", gfc_match_oacc_declare
, ST_OACC_DECLARE
);
623 match ("end data", gfc_match_omp_eos
, ST_OACC_END_DATA
);
624 match ("end host_data", gfc_match_omp_eos
, ST_OACC_END_HOST_DATA
);
625 match ("end kernels loop", gfc_match_omp_eos
, ST_OACC_END_KERNELS_LOOP
);
626 match ("end kernels", gfc_match_omp_eos
, ST_OACC_END_KERNELS
);
627 match ("end loop", gfc_match_omp_eos
, ST_OACC_END_LOOP
);
628 match ("end parallel loop", gfc_match_omp_eos
, ST_OACC_END_PARALLEL_LOOP
);
629 match ("end parallel", gfc_match_omp_eos
, ST_OACC_END_PARALLEL
);
630 match ("enter data", gfc_match_oacc_enter_data
, ST_OACC_ENTER_DATA
);
631 match ("exit data", gfc_match_oacc_exit_data
, ST_OACC_EXIT_DATA
);
634 match ("host_data", gfc_match_oacc_host_data
, ST_OACC_HOST_DATA
);
637 match ("parallel loop", gfc_match_oacc_parallel_loop
, ST_OACC_PARALLEL_LOOP
);
638 match ("parallel", gfc_match_oacc_parallel
, ST_OACC_PARALLEL
);
641 match ("kernels loop", gfc_match_oacc_kernels_loop
, ST_OACC_KERNELS_LOOP
);
642 match ("kernels", gfc_match_oacc_kernels
, ST_OACC_KERNELS
);
645 match ("loop", gfc_match_oacc_loop
, ST_OACC_LOOP
);
648 match ("routine", gfc_match_oacc_routine
, ST_OACC_ROUTINE
);
651 match ("update", gfc_match_oacc_update
, ST_OACC_UPDATE
);
654 match ("wait", gfc_match_oacc_wait
, ST_OACC_WAIT
);
658 /* Directive not found or stored an error message.
659 Check and give up. */
661 if (gfc_error_check () == 0)
662 gfc_error_now ("Unclassifiable OpenACC directive at %C");
666 gfc_error_recovery ();
672 decode_omp_directive (void)
676 bool simd_matched
= false;
678 gfc_enforce_clean_symbol_state ();
680 gfc_clear_error (); /* Clear any pending errors. */
681 gfc_clear_warning (); /* Clear any pending warnings. */
685 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
686 "or ELEMENTAL procedures");
687 gfc_error_recovery ();
691 gfc_unset_implicit_pure (NULL
);
693 old_locus
= gfc_current_locus
;
695 /* General OpenMP directive matching: Instead of testing every possible
696 statement, we eliminate most possibilities by peeking at the
699 c
= gfc_peek_ascii_char ();
701 /* match is for directives that should be recognized only if
702 -fopenmp, matchs for directives that should be recognized
703 if either -fopenmp or -fopenmp-simd. */
707 matcho ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
710 matcho ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
713 matcho ("cancellation% point", gfc_match_omp_cancellation_point
,
714 ST_OMP_CANCELLATION_POINT
);
715 matcho ("cancel", gfc_match_omp_cancel
, ST_OMP_CANCEL
);
716 matcho ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
719 matchs ("declare reduction", gfc_match_omp_declare_reduction
,
720 ST_OMP_DECLARE_REDUCTION
);
721 matchs ("declare simd", gfc_match_omp_declare_simd
,
722 ST_OMP_DECLARE_SIMD
);
723 matcho ("declare target", gfc_match_omp_declare_target
,
724 ST_OMP_DECLARE_TARGET
);
725 matchs ("distribute parallel do simd",
726 gfc_match_omp_distribute_parallel_do_simd
,
727 ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
);
728 matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do
,
729 ST_OMP_DISTRIBUTE_PARALLEL_DO
);
730 matchs ("distribute simd", gfc_match_omp_distribute_simd
,
731 ST_OMP_DISTRIBUTE_SIMD
);
732 matcho ("distribute", gfc_match_omp_distribute
, ST_OMP_DISTRIBUTE
);
733 matchs ("do simd", gfc_match_omp_do_simd
, ST_OMP_DO_SIMD
);
734 matcho ("do", gfc_match_omp_do
, ST_OMP_DO
);
737 matcho ("end atomic", gfc_match_omp_eos
, ST_OMP_END_ATOMIC
);
738 matcho ("end critical", gfc_match_omp_critical
, ST_OMP_END_CRITICAL
);
739 matchs ("end distribute parallel do simd", gfc_match_omp_eos
,
740 ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
);
741 matcho ("end distribute parallel do", gfc_match_omp_eos
,
742 ST_OMP_END_DISTRIBUTE_PARALLEL_DO
);
743 matchs ("end distribute simd", gfc_match_omp_eos
,
744 ST_OMP_END_DISTRIBUTE_SIMD
);
745 matcho ("end distribute", gfc_match_omp_eos
, ST_OMP_END_DISTRIBUTE
);
746 matchs ("end do simd", gfc_match_omp_end_nowait
, ST_OMP_END_DO_SIMD
);
747 matcho ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
748 matchs ("end simd", gfc_match_omp_eos
, ST_OMP_END_SIMD
);
749 matcho ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
750 matcho ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
751 matchs ("end parallel do simd", gfc_match_omp_eos
,
752 ST_OMP_END_PARALLEL_DO_SIMD
);
753 matcho ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
754 matcho ("end parallel sections", gfc_match_omp_eos
,
755 ST_OMP_END_PARALLEL_SECTIONS
);
756 matcho ("end parallel workshare", gfc_match_omp_eos
,
757 ST_OMP_END_PARALLEL_WORKSHARE
);
758 matcho ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
759 matcho ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
760 matcho ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
761 matcho ("end target data", gfc_match_omp_eos
, ST_OMP_END_TARGET_DATA
);
762 matchs ("end target teams distribute parallel do simd",
764 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
765 matcho ("end target teams distribute parallel do", gfc_match_omp_eos
,
766 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
767 matchs ("end target teams distribute simd", gfc_match_omp_eos
,
768 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
);
769 matcho ("end target teams distribute", gfc_match_omp_eos
,
770 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
);
771 matcho ("end target teams", gfc_match_omp_eos
, ST_OMP_END_TARGET_TEAMS
);
772 matcho ("end target", gfc_match_omp_eos
, ST_OMP_END_TARGET
);
773 matcho ("end taskgroup", gfc_match_omp_eos
, ST_OMP_END_TASKGROUP
);
774 matcho ("end task", gfc_match_omp_eos
, ST_OMP_END_TASK
);
775 matchs ("end teams distribute parallel do simd", gfc_match_omp_eos
,
776 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
777 matcho ("end teams distribute parallel do", gfc_match_omp_eos
,
778 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
);
779 matchs ("end teams distribute simd", gfc_match_omp_eos
,
780 ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
);
781 matcho ("end teams distribute", gfc_match_omp_eos
,
782 ST_OMP_END_TEAMS_DISTRIBUTE
);
783 matcho ("end teams", gfc_match_omp_eos
, ST_OMP_END_TEAMS
);
784 matcho ("end workshare", gfc_match_omp_end_nowait
,
785 ST_OMP_END_WORKSHARE
);
788 matcho ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
791 matcho ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
794 matcho ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
797 matchs ("parallel do simd", gfc_match_omp_parallel_do_simd
,
798 ST_OMP_PARALLEL_DO_SIMD
);
799 matcho ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
800 matcho ("parallel sections", gfc_match_omp_parallel_sections
,
801 ST_OMP_PARALLEL_SECTIONS
);
802 matcho ("parallel workshare", gfc_match_omp_parallel_workshare
,
803 ST_OMP_PARALLEL_WORKSHARE
);
804 matcho ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
807 matcho ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
808 matcho ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
809 matchs ("simd", gfc_match_omp_simd
, ST_OMP_SIMD
);
810 matcho ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
813 matcho ("target data", gfc_match_omp_target_data
, ST_OMP_TARGET_DATA
);
814 matchs ("target teams distribute parallel do simd",
815 gfc_match_omp_target_teams_distribute_parallel_do_simd
,
816 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
817 matcho ("target teams distribute parallel do",
818 gfc_match_omp_target_teams_distribute_parallel_do
,
819 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
820 matchs ("target teams distribute simd",
821 gfc_match_omp_target_teams_distribute_simd
,
822 ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
);
823 matcho ("target teams distribute", gfc_match_omp_target_teams_distribute
,
824 ST_OMP_TARGET_TEAMS_DISTRIBUTE
);
825 matcho ("target teams", gfc_match_omp_target_teams
, ST_OMP_TARGET_TEAMS
);
826 matcho ("target update", gfc_match_omp_target_update
,
827 ST_OMP_TARGET_UPDATE
);
828 matcho ("target", gfc_match_omp_target
, ST_OMP_TARGET
);
829 matcho ("taskgroup", gfc_match_omp_taskgroup
, ST_OMP_TASKGROUP
);
830 matcho ("taskwait", gfc_match_omp_taskwait
, ST_OMP_TASKWAIT
);
831 matcho ("taskyield", gfc_match_omp_taskyield
, ST_OMP_TASKYIELD
);
832 matcho ("task", gfc_match_omp_task
, ST_OMP_TASK
);
833 matchs ("teams distribute parallel do simd",
834 gfc_match_omp_teams_distribute_parallel_do_simd
,
835 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
836 matcho ("teams distribute parallel do",
837 gfc_match_omp_teams_distribute_parallel_do
,
838 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
);
839 matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd
,
840 ST_OMP_TEAMS_DISTRIBUTE_SIMD
);
841 matcho ("teams distribute", gfc_match_omp_teams_distribute
,
842 ST_OMP_TEAMS_DISTRIBUTE
);
843 matcho ("teams", gfc_match_omp_teams
, ST_OMP_TEAMS
);
844 matcho ("threadprivate", gfc_match_omp_threadprivate
,
845 ST_OMP_THREADPRIVATE
);
848 matcho ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
852 /* All else has failed, so give up. See if any of the matchers has
853 stored an error message of some sort. Don't error out if
854 not -fopenmp and simd_matched is false, i.e. if a directive other
855 than one marked with match has been seen. */
857 if (gfc_option
.gfc_flag_openmp
|| simd_matched
)
859 if (gfc_error_check () == 0)
860 gfc_error_now ("Unclassifiable OpenMP directive at %C");
865 gfc_error_recovery ();
871 decode_gcc_attribute (void)
875 gfc_enforce_clean_symbol_state ();
877 gfc_clear_error (); /* Clear any pending errors. */
878 gfc_clear_warning (); /* Clear any pending warnings. */
879 old_locus
= gfc_current_locus
;
881 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
883 /* All else has failed, so give up. See if any of the matchers has
884 stored an error message of some sort. */
886 if (gfc_error_check () == 0)
887 gfc_error_now_2 ("Unclassifiable GCC directive at %C");
891 gfc_error_recovery ();
898 /* Assert next length characters to be equal to token in free form. */
901 verify_token_free (const char* token
, int length
, bool last_was_use_stmt
)
906 c
= gfc_next_ascii_char ();
907 for (i
= 0; i
< length
; i
++, c
= gfc_next_ascii_char ())
908 gcc_assert (c
== token
[i
]);
910 gcc_assert (gfc_is_whitespace(c
));
911 gfc_gobble_whitespace ();
912 if (last_was_use_stmt
)
916 /* Get the next statement in free form source. */
925 at_bol
= gfc_at_bol ();
926 gfc_gobble_whitespace ();
928 c
= gfc_peek_ascii_char ();
934 /* Found a statement label? */
935 m
= gfc_match_st_label (&gfc_statement_label
);
937 d
= gfc_peek_ascii_char ();
938 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
940 gfc_match_small_literal_int (&i
, &cnt
);
943 gfc_error_now_2 ("Too many digits in statement label at %C");
946 gfc_error_now_2 ("Zero is not a valid statement label at %C");
949 c
= gfc_next_ascii_char ();
952 if (!gfc_is_whitespace (c
))
953 gfc_error_now_2 ("Non-numeric character in statement label at %C");
959 label_locus
= gfc_current_locus
;
961 gfc_gobble_whitespace ();
963 if (at_bol
&& gfc_peek_ascii_char () == ';')
965 gfc_error_now_2 ("Semicolon at %C needs to be preceded by "
967 gfc_next_ascii_char (); /* Eat up the semicolon. */
971 if (gfc_match_eos () == MATCH_YES
)
973 gfc_warning_now ("Ignoring statement label in empty statement "
974 "at %L", &label_locus
);
975 gfc_free_st_label (gfc_statement_label
);
976 gfc_statement_label
= NULL
;
983 /* Comments have already been skipped by the time we get here,
984 except for GCC attributes and OpenMP/OpenACC directives. */
986 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
987 c
= gfc_peek_ascii_char ();
993 c
= gfc_next_ascii_char ();
994 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
995 gcc_assert (c
== "gcc$"[i
]);
997 gfc_gobble_whitespace ();
998 return decode_gcc_attribute ();
1003 /* Since both OpenMP and OpenACC directives starts with
1004 !$ character sequence, we must check all flags combinations */
1005 if ((gfc_option
.gfc_flag_openmp
1006 || gfc_option
.gfc_flag_openmp_simd
)
1007 && !gfc_option
.gfc_flag_openacc
)
1009 verify_token_free ("$omp", 4, last_was_use_stmt
);
1010 return decode_omp_directive ();
1012 else if ((gfc_option
.gfc_flag_openmp
1013 || gfc_option
.gfc_flag_openmp_simd
)
1014 && gfc_option
.gfc_flag_openacc
)
1016 gfc_next_ascii_char (); /* Eat up dollar character */
1017 c
= gfc_peek_ascii_char ();
1021 verify_token_free ("omp", 3, last_was_use_stmt
);
1022 return decode_omp_directive ();
1026 verify_token_free ("acc", 3, last_was_use_stmt
);
1027 return decode_oacc_directive ();
1030 else if (gfc_option
.gfc_flag_openacc
)
1032 verify_token_free ("$acc", 4, last_was_use_stmt
);
1033 return decode_oacc_directive ();
1039 if (at_bol
&& c
== ';')
1041 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1042 gfc_error_now_2 ("Fortran 2008: Semicolon at %C without preceding "
1044 gfc_next_ascii_char (); /* Eat up the semicolon. */
1048 return decode_statement ();
1051 /* Assert next length characters to be equal to token in fixed form. */
1054 verify_token_fixed (const char *token
, int length
, bool last_was_use_stmt
)
1057 char c
= gfc_next_char_literal (NONSTRING
);
1059 for (i
= 0; i
< length
; i
++, c
= gfc_next_char_literal (NONSTRING
))
1060 gcc_assert ((char) gfc_wide_tolower (c
) == token
[i
]);
1062 if (c
!= ' ' && c
!= '0')
1064 gfc_buffer_error (0);
1065 gfc_error ("Bad continuation line at %C");
1068 if (last_was_use_stmt
)
1074 /* Get the next statement in fixed-form source. */
1076 static gfc_statement
1079 int label
, digit_flag
, i
;
1084 return decode_statement ();
1086 /* Skip past the current label field, parsing a statement label if
1087 one is there. This is a weird number parser, since the number is
1088 contained within five columns and can have any kind of embedded
1089 spaces. We also check for characters that make the rest of the
1095 for (i
= 0; i
< 5; i
++)
1097 c
= gfc_next_char_literal (NONSTRING
);
1114 label
= label
* 10 + ((unsigned char) c
- '0');
1115 label_locus
= gfc_current_locus
;
1119 /* Comments have already been skipped by the time we get
1120 here, except for GCC attributes and OpenMP directives. */
1123 c
= gfc_next_char_literal (NONSTRING
);
1125 if (TOLOWER (c
) == 'g')
1127 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
1128 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
1130 return decode_gcc_attribute ();
1134 if ((gfc_option
.gfc_flag_openmp
1135 || gfc_option
.gfc_flag_openmp_simd
)
1136 && !gfc_option
.gfc_flag_openacc
)
1138 if (!verify_token_fixed ("omp", 3, last_was_use_stmt
))
1140 return decode_omp_directive ();
1142 else if ((gfc_option
.gfc_flag_openmp
1143 || gfc_option
.gfc_flag_openmp_simd
)
1144 && gfc_option
.gfc_flag_openacc
)
1146 c
= gfc_next_char_literal(NONSTRING
);
1147 if (c
== 'o' || c
== 'O')
1149 if (!verify_token_fixed ("mp", 2, last_was_use_stmt
))
1151 return decode_omp_directive ();
1153 else if (c
== 'a' || c
== 'A')
1155 if (!verify_token_fixed ("cc", 2, last_was_use_stmt
))
1157 return decode_oacc_directive ();
1160 else if (gfc_option
.gfc_flag_openacc
)
1162 if (!verify_token_fixed ("acc", 3, last_was_use_stmt
))
1164 return decode_oacc_directive ();
1169 /* Comments have already been skipped by the time we get
1170 here so don't bother checking for them. */
1173 gfc_buffer_error (0);
1174 gfc_error ("Non-numeric character in statement label at %C");
1182 gfc_warning_now_2 ("Zero is not a valid statement label at %C");
1185 /* We've found a valid statement label. */
1186 gfc_statement_label
= gfc_get_st_label (label
);
1190 /* Since this line starts a statement, it cannot be a continuation
1191 of a previous statement. If we see something here besides a
1192 space or zero, it must be a bad continuation line. */
1194 c
= gfc_next_char_literal (NONSTRING
);
1198 if (c
!= ' ' && c
!= '0')
1200 gfc_buffer_error (0);
1201 gfc_error ("Bad continuation line at %C");
1205 /* Now that we've taken care of the statement label columns, we have
1206 to make sure that the first nonblank character is not a '!'. If
1207 it is, the rest of the line is a comment. */
1211 loc
= gfc_current_locus
;
1212 c
= gfc_next_char_literal (NONSTRING
);
1214 while (gfc_is_whitespace (c
));
1218 gfc_current_locus
= loc
;
1223 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1224 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1225 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1230 if (gfc_match_eos () == MATCH_YES
)
1233 /* At this point, we've got a nonblank statement to parse. */
1234 return decode_statement ();
1238 gfc_warning_now ("Ignoring statement label in empty statement at %L",
1241 gfc_current_locus
.lb
->truncated
= 0;
1242 gfc_advance_line ();
1247 /* Return the next non-ST_NONE statement to the caller. We also worry
1248 about including files and the ends of include files at this stage. */
1250 static gfc_statement
1251 next_statement (void)
1256 gfc_enforce_clean_symbol_state ();
1258 gfc_new_block
= NULL
;
1260 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
1261 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1264 gfc_statement_label
= NULL
;
1265 gfc_buffer_error (1);
1268 gfc_advance_line ();
1270 gfc_skip_comments ();
1278 if (gfc_define_undef_line ())
1281 old_locus
= gfc_current_locus
;
1283 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1289 gfc_buffer_error (0);
1291 if (st
== ST_GET_FCN_CHARACTERISTICS
&& gfc_statement_label
!= NULL
)
1293 gfc_free_st_label (gfc_statement_label
);
1294 gfc_statement_label
= NULL
;
1295 gfc_current_locus
= old_locus
;
1299 check_statement_label (st
);
1305 /****************************** Parser ***********************************/
1307 /* The parser subroutines are of type 'try' that fail if the file ends
1310 /* Macros that expand to case-labels for various classes of
1311 statements. Start with executable statements that directly do
1314 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1315 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1316 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1317 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1318 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1319 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1320 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1321 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1322 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1323 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
1324 case ST_OMP_TARGET_UPDATE: case ST_ERROR_STOP: case ST_SYNC_ALL: \
1325 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1326 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1327 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1329 /* Statements that mark other executable statements. */
1331 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1332 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1333 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1334 case ST_OMP_PARALLEL: \
1335 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1336 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
1337 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1338 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1339 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1340 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1341 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1342 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1343 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1344 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1345 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1346 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1347 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1348 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1349 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1350 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1351 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: \
1353 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1354 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: case ST_OACC_KERNELS_LOOP
1356 /* Declaration statements */
1358 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1359 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1360 case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
1361 case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD: case ST_OMP_DECLARE_REDUCTION: \
1362 case ST_OMP_DECLARE_TARGET: case ST_OACC_ROUTINE
1364 /* Block end statements. Errors associated with interchanging these
1365 are detected in gfc_match_end(). */
1367 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1368 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1369 case ST_END_BLOCK: case ST_END_ASSOCIATE
1372 /* Push a new state onto the stack. */
1375 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1377 p
->state
= new_state
;
1378 p
->previous
= gfc_state_stack
;
1380 p
->head
= p
->tail
= NULL
;
1381 p
->do_variable
= NULL
;
1382 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1383 p
->ext
.oacc_declare_clauses
= NULL
;
1385 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1386 construct statement was accepted right before pushing the state. Thus,
1387 the construct's gfc_code is available as tail of the parent state. */
1388 gcc_assert (gfc_state_stack
);
1389 p
->construct
= gfc_state_stack
->tail
;
1391 gfc_state_stack
= p
;
1395 /* Pop the current state. */
1399 gfc_state_stack
= gfc_state_stack
->previous
;
1403 /* Try to find the given state in the state stack. */
1406 gfc_find_state (gfc_compile_state state
)
1410 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1411 if (p
->state
== state
)
1414 return (p
== NULL
) ? false : true;
1418 /* Starts a new level in the statement list. */
1421 new_level (gfc_code
*q
)
1425 p
= q
->block
= gfc_get_code (EXEC_NOP
);
1427 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1433 /* Add the current new_st code structure and adds it to the current
1434 program unit. As a side-effect, it zeroes the new_st. */
1437 add_statement (void)
1441 p
= XCNEW (gfc_code
);
1444 p
->loc
= gfc_current_locus
;
1446 if (gfc_state_stack
->head
== NULL
)
1447 gfc_state_stack
->head
= p
;
1449 gfc_state_stack
->tail
->next
= p
;
1451 while (p
->next
!= NULL
)
1454 gfc_state_stack
->tail
= p
;
1456 gfc_clear_new_st ();
1462 /* Frees everything associated with the current statement. */
1465 undo_new_statement (void)
1467 gfc_free_statements (new_st
.block
);
1468 gfc_free_statements (new_st
.next
);
1469 gfc_free_statement (&new_st
);
1470 gfc_clear_new_st ();
1474 /* If the current statement has a statement label, make sure that it
1475 is allowed to, or should have one. */
1478 check_statement_label (gfc_statement st
)
1482 if (gfc_statement_label
== NULL
)
1484 if (st
== ST_FORMAT
)
1485 gfc_error ("FORMAT statement at %L does not have a statement label",
1492 case ST_END_PROGRAM
:
1493 case ST_END_FUNCTION
:
1494 case ST_END_SUBROUTINE
:
1498 case ST_END_CRITICAL
:
1500 case ST_END_ASSOCIATE
:
1503 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
1504 type
= ST_LABEL_DO_TARGET
;
1506 type
= ST_LABEL_TARGET
;
1510 type
= ST_LABEL_FORMAT
;
1513 /* Statement labels are not restricted from appearing on a
1514 particular line. However, there are plenty of situations
1515 where the resulting label can't be referenced. */
1518 type
= ST_LABEL_BAD_TARGET
;
1522 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1524 new_st
.here
= gfc_statement_label
;
1528 /* Figures out what the enclosing program unit is. This will be a
1529 function, subroutine, program, block data or module. */
1532 gfc_enclosing_unit (gfc_compile_state
* result
)
1536 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1537 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1538 || p
->state
== COMP_MODULE
|| p
->state
== COMP_BLOCK_DATA
1539 || p
->state
== COMP_PROGRAM
)
1548 *result
= COMP_PROGRAM
;
1553 /* Translate a statement enum to a string. */
1556 gfc_ascii_statement (gfc_statement st
)
1562 case ST_ARITHMETIC_IF
:
1563 p
= _("arithmetic IF");
1572 p
= _("attribute declaration");
1608 p
= _("data declaration");
1616 case ST_DERIVED_DECL
:
1617 p
= _("derived type declaration");
1631 case ST_END_ASSOCIATE
:
1632 p
= "END ASSOCIATE";
1637 case ST_END_BLOCK_DATA
:
1638 p
= "END BLOCK DATA";
1640 case ST_END_CRITICAL
:
1652 case ST_END_FUNCTION
:
1658 case ST_END_INTERFACE
:
1659 p
= "END INTERFACE";
1664 case ST_END_PROGRAM
:
1670 case ST_END_SUBROUTINE
:
1671 p
= "END SUBROUTINE";
1682 case ST_EQUIVALENCE
:
1694 case ST_FORALL_BLOCK
: /* Fall through */
1716 case ST_IMPLICIT_NONE
:
1717 p
= "IMPLICIT NONE";
1719 case ST_IMPLIED_ENDDO
:
1720 p
= _("implied END DO");
1749 case ST_MODULE_PROC
:
1750 p
= "MODULE PROCEDURE";
1782 case ST_SYNC_IMAGES
:
1785 case ST_SYNC_MEMORY
:
1800 case ST_WHERE_BLOCK
: /* Fall through */
1811 p
= _("assignment");
1813 case ST_POINTER_ASSIGNMENT
:
1814 p
= _("pointer assignment");
1816 case ST_SELECT_CASE
:
1819 case ST_SELECT_TYPE
:
1834 case ST_STATEMENT_FUNCTION
:
1835 p
= "STATEMENT FUNCTION";
1837 case ST_LABEL_ASSIGNMENT
:
1838 p
= "LABEL ASSIGNMENT";
1841 p
= "ENUM DEFINITION";
1844 p
= "ENUMERATOR DEFINITION";
1849 case ST_OACC_PARALLEL_LOOP
:
1850 p
= "!$ACC PARALLEL LOOP";
1852 case ST_OACC_END_PARALLEL_LOOP
:
1853 p
= "!$ACC END PARALLEL LOOP";
1855 case ST_OACC_PARALLEL
:
1856 p
= "!$ACC PARALLEL";
1858 case ST_OACC_END_PARALLEL
:
1859 p
= "!$ACC END PARALLEL";
1861 case ST_OACC_KERNELS
:
1862 p
= "!$ACC KERNELS";
1864 case ST_OACC_END_KERNELS
:
1865 p
= "!$ACC END KERNELS";
1867 case ST_OACC_KERNELS_LOOP
:
1868 p
= "!$ACC KERNELS LOOP";
1870 case ST_OACC_END_KERNELS_LOOP
:
1871 p
= "!$ACC END KERNELS LOOP";
1876 case ST_OACC_END_DATA
:
1877 p
= "!$ACC END DATA";
1879 case ST_OACC_HOST_DATA
:
1880 p
= "!$ACC HOST_DATA";
1882 case ST_OACC_END_HOST_DATA
:
1883 p
= "!$ACC END HOST_DATA";
1888 case ST_OACC_END_LOOP
:
1889 p
= "!$ACC END LOOP";
1891 case ST_OACC_DECLARE
:
1892 p
= "!$ACC DECLARE";
1894 case ST_OACC_UPDATE
:
1903 case ST_OACC_ENTER_DATA
:
1904 p
= "!$ACC ENTER DATA";
1906 case ST_OACC_EXIT_DATA
:
1907 p
= "!$ACC EXIT DATA";
1909 case ST_OACC_ROUTINE
:
1910 p
= "!$ACC ROUTINE";
1915 case ST_OMP_BARRIER
:
1916 p
= "!$OMP BARRIER";
1921 case ST_OMP_CANCELLATION_POINT
:
1922 p
= "!$OMP CANCELLATION POINT";
1924 case ST_OMP_CRITICAL
:
1925 p
= "!$OMP CRITICAL";
1927 case ST_OMP_DECLARE_REDUCTION
:
1928 p
= "!$OMP DECLARE REDUCTION";
1930 case ST_OMP_DECLARE_SIMD
:
1931 p
= "!$OMP DECLARE SIMD";
1933 case ST_OMP_DECLARE_TARGET
:
1934 p
= "!$OMP DECLARE TARGET";
1936 case ST_OMP_DISTRIBUTE
:
1937 p
= "!$OMP DISTRIBUTE";
1939 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
1940 p
= "!$OMP DISTRIBUTE PARALLEL DO";
1942 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
1943 p
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
1945 case ST_OMP_DISTRIBUTE_SIMD
:
1946 p
= "!$OMP DISTRIBUTE SIMD";
1951 case ST_OMP_DO_SIMD
:
1952 p
= "!$OMP DO SIMD";
1954 case ST_OMP_END_ATOMIC
:
1955 p
= "!$OMP END ATOMIC";
1957 case ST_OMP_END_CRITICAL
:
1958 p
= "!$OMP END CRITICAL";
1960 case ST_OMP_END_DISTRIBUTE
:
1961 p
= "!$OMP END DISTRIBUTE";
1963 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO
:
1964 p
= "!$OMP END DISTRIBUTE PARALLEL DO";
1966 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
:
1967 p
= "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
1969 case ST_OMP_END_DISTRIBUTE_SIMD
:
1970 p
= "!$OMP END DISTRIBUTE SIMD";
1975 case ST_OMP_END_DO_SIMD
:
1976 p
= "!$OMP END DO SIMD";
1978 case ST_OMP_END_SIMD
:
1979 p
= "!$OMP END SIMD";
1981 case ST_OMP_END_MASTER
:
1982 p
= "!$OMP END MASTER";
1984 case ST_OMP_END_ORDERED
:
1985 p
= "!$OMP END ORDERED";
1987 case ST_OMP_END_PARALLEL
:
1988 p
= "!$OMP END PARALLEL";
1990 case ST_OMP_END_PARALLEL_DO
:
1991 p
= "!$OMP END PARALLEL DO";
1993 case ST_OMP_END_PARALLEL_DO_SIMD
:
1994 p
= "!$OMP END PARALLEL DO SIMD";
1996 case ST_OMP_END_PARALLEL_SECTIONS
:
1997 p
= "!$OMP END PARALLEL SECTIONS";
1999 case ST_OMP_END_PARALLEL_WORKSHARE
:
2000 p
= "!$OMP END PARALLEL WORKSHARE";
2002 case ST_OMP_END_SECTIONS
:
2003 p
= "!$OMP END SECTIONS";
2005 case ST_OMP_END_SINGLE
:
2006 p
= "!$OMP END SINGLE";
2008 case ST_OMP_END_TASK
:
2009 p
= "!$OMP END TASK";
2011 case ST_OMP_END_TARGET
:
2012 p
= "!$OMP END TARGET";
2014 case ST_OMP_END_TARGET_DATA
:
2015 p
= "!$OMP END TARGET DATA";
2017 case ST_OMP_END_TARGET_TEAMS
:
2018 p
= "!$OMP END TARGET TEAMS";
2020 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
:
2021 p
= "!$OMP END TARGET TEAMS DISTRIBUTE";
2023 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2024 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2026 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2027 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2029 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2030 p
= "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2032 case ST_OMP_END_TASKGROUP
:
2033 p
= "!$OMP END TASKGROUP";
2035 case ST_OMP_END_TEAMS
:
2036 p
= "!$OMP END TEAMS";
2038 case ST_OMP_END_TEAMS_DISTRIBUTE
:
2039 p
= "!$OMP END TEAMS DISTRIBUTE";
2041 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2042 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2044 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2045 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2047 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
:
2048 p
= "!$OMP END TEAMS DISTRIBUTE SIMD";
2050 case ST_OMP_END_WORKSHARE
:
2051 p
= "!$OMP END WORKSHARE";
2059 case ST_OMP_ORDERED
:
2060 p
= "!$OMP ORDERED";
2062 case ST_OMP_PARALLEL
:
2063 p
= "!$OMP PARALLEL";
2065 case ST_OMP_PARALLEL_DO
:
2066 p
= "!$OMP PARALLEL DO";
2068 case ST_OMP_PARALLEL_DO_SIMD
:
2069 p
= "!$OMP PARALLEL DO SIMD";
2071 case ST_OMP_PARALLEL_SECTIONS
:
2072 p
= "!$OMP PARALLEL SECTIONS";
2074 case ST_OMP_PARALLEL_WORKSHARE
:
2075 p
= "!$OMP PARALLEL WORKSHARE";
2077 case ST_OMP_SECTIONS
:
2078 p
= "!$OMP SECTIONS";
2080 case ST_OMP_SECTION
:
2081 p
= "!$OMP SECTION";
2092 case ST_OMP_TARGET_DATA
:
2093 p
= "!$OMP TARGET DATA";
2095 case ST_OMP_TARGET_TEAMS
:
2096 p
= "!$OMP TARGET TEAMS";
2098 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
2099 p
= "!$OMP TARGET TEAMS DISTRIBUTE";
2101 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2102 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2104 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2105 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2107 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2108 p
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2110 case ST_OMP_TARGET_UPDATE
:
2111 p
= "!$OMP TARGET UPDATE";
2116 case ST_OMP_TASKGROUP
:
2117 p
= "!$OMP TASKGROUP";
2119 case ST_OMP_TASKWAIT
:
2120 p
= "!$OMP TASKWAIT";
2122 case ST_OMP_TASKYIELD
:
2123 p
= "!$OMP TASKYIELD";
2128 case ST_OMP_TEAMS_DISTRIBUTE
:
2129 p
= "!$OMP TEAMS DISTRIBUTE";
2131 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2132 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2134 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2135 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2137 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
2138 p
= "!$OMP TEAMS DISTRIBUTE SIMD";
2140 case ST_OMP_THREADPRIVATE
:
2141 p
= "!$OMP THREADPRIVATE";
2143 case ST_OMP_WORKSHARE
:
2144 p
= "!$OMP WORKSHARE";
2147 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2154 /* Create a symbol for the main program and assign it to ns->proc_name. */
2157 main_program_symbol (gfc_namespace
*ns
, const char *name
)
2159 gfc_symbol
*main_program
;
2160 symbol_attribute attr
;
2162 gfc_get_symbol (name
, ns
, &main_program
);
2163 gfc_clear_attr (&attr
);
2164 attr
.flavor
= FL_PROGRAM
;
2165 attr
.proc
= PROC_UNKNOWN
;
2166 attr
.subroutine
= 1;
2167 attr
.access
= ACCESS_PUBLIC
;
2168 attr
.is_main_program
= 1;
2169 main_program
->attr
= attr
;
2170 main_program
->declared_at
= gfc_current_locus
;
2171 ns
->proc_name
= main_program
;
2172 gfc_commit_symbols ();
2176 /* Do whatever is necessary to accept the last statement. */
2179 accept_statement (gfc_statement st
)
2183 case ST_IMPLICIT_NONE
:
2190 gfc_current_ns
->proc_name
= gfc_new_block
;
2193 /* If the statement is the end of a block, lay down a special code
2194 that allows a branch to the end of the block from within the
2195 construct. IF and SELECT are treated differently from DO
2196 (where EXEC_NOP is added inside the loop) for two
2198 1. END DO has a meaning in the sense that after a GOTO to
2199 it, the loop counter must be increased.
2200 2. IF blocks and SELECT blocks can consist of multiple
2201 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
2202 Putting the label before the END IF would make the jump
2203 from, say, the ELSE IF block to the END IF illegal. */
2207 case ST_END_CRITICAL
:
2208 if (gfc_statement_label
!= NULL
)
2210 new_st
.op
= EXEC_END_NESTED_BLOCK
;
2215 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
2216 one parallel block. Thus, we add the special code to the nested block
2217 itself, instead of the parent one. */
2219 case ST_END_ASSOCIATE
:
2220 if (gfc_statement_label
!= NULL
)
2222 new_st
.op
= EXEC_END_BLOCK
;
2227 /* The end-of-program unit statements do not get the special
2228 marker and require a statement of some sort if they are a
2231 case ST_END_PROGRAM
:
2232 case ST_END_FUNCTION
:
2233 case ST_END_SUBROUTINE
:
2234 if (gfc_statement_label
!= NULL
)
2236 new_st
.op
= EXEC_RETURN
;
2241 new_st
.op
= EXEC_END_PROCEDURE
;
2257 gfc_commit_symbols ();
2258 gfc_warning_check ();
2259 gfc_clear_new_st ();
2263 /* Undo anything tentative that has been built for the current
2267 reject_statement (void)
2269 /* Revert to the previous charlen chain. */
2270 gfc_free_charlen (gfc_current_ns
->cl_list
, gfc_current_ns
->old_cl_list
);
2271 gfc_current_ns
->cl_list
= gfc_current_ns
->old_cl_list
;
2273 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
2274 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
2276 gfc_new_block
= NULL
;
2277 gfc_undo_symbols ();
2278 gfc_clear_warning ();
2279 undo_new_statement ();
2283 /* Generic complaint about an out of order statement. We also do
2284 whatever is necessary to clean up. */
2287 unexpected_statement (gfc_statement st
)
2289 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
2291 reject_statement ();
2295 /* Given the next statement seen by the matcher, make sure that it is
2296 in proper order with the last. This subroutine is initialized by
2297 calling it with an argument of ST_NONE. If there is a problem, we
2298 issue an error and return false. Otherwise we return true.
2300 Individual parsers need to verify that the statements seen are
2301 valid before calling here, i.e., ENTRY statements are not allowed in
2302 INTERFACE blocks. The following diagram is taken from the standard:
2304 +---------------------------------------+
2305 | program subroutine function module |
2306 +---------------------------------------+
2308 +---------------------------------------+
2310 +---------------------------------------+
2312 | +-----------+------------------+
2313 | | parameter | implicit |
2314 | +-----------+------------------+
2315 | format | | derived type |
2316 | entry | parameter | interface |
2317 | | data | specification |
2318 | | | statement func |
2319 | +-----------+------------------+
2320 | | data | executable |
2321 +--------+-----------+------------------+
2323 +---------------------------------------+
2324 | internal module/subprogram |
2325 +---------------------------------------+
2327 +---------------------------------------+
2336 ORDER_IMPLICIT_NONE
,
2344 enum state_order state
;
2345 gfc_statement last_statement
;
2351 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
2357 p
->state
= ORDER_START
;
2361 if (p
->state
> ORDER_USE
)
2363 p
->state
= ORDER_USE
;
2367 if (p
->state
> ORDER_IMPORT
)
2369 p
->state
= ORDER_IMPORT
;
2372 case ST_IMPLICIT_NONE
:
2373 if (p
->state
> ORDER_IMPLICIT
)
2376 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2377 statement disqualifies a USE but not an IMPLICIT NONE.
2378 Duplicate IMPLICIT NONEs are caught when the implicit types
2381 p
->state
= ORDER_IMPLICIT_NONE
;
2385 if (p
->state
> ORDER_IMPLICIT
)
2387 p
->state
= ORDER_IMPLICIT
;
2392 if (p
->state
< ORDER_IMPLICIT_NONE
)
2393 p
->state
= ORDER_IMPLICIT_NONE
;
2397 if (p
->state
>= ORDER_EXEC
)
2399 if (p
->state
< ORDER_IMPLICIT
)
2400 p
->state
= ORDER_IMPLICIT
;
2404 if (p
->state
< ORDER_SPEC
)
2405 p
->state
= ORDER_SPEC
;
2410 case ST_DERIVED_DECL
:
2411 case ST_OACC_DECLARE
:
2413 if (p
->state
>= ORDER_EXEC
)
2415 if (p
->state
< ORDER_SPEC
)
2416 p
->state
= ORDER_SPEC
;
2421 if (p
->state
< ORDER_EXEC
)
2422 p
->state
= ORDER_EXEC
;
2426 gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
2427 gfc_ascii_statement (st
));
2430 /* All is well, record the statement in case we need it next time. */
2431 p
->where
= gfc_current_locus
;
2432 p
->last_statement
= st
;
2437 gfc_error ("%s statement at %C cannot follow %s statement at %L",
2438 gfc_ascii_statement (st
),
2439 gfc_ascii_statement (p
->last_statement
), &p
->where
);
2445 /* Handle an unexpected end of file. This is a show-stopper... */
2447 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
2450 unexpected_eof (void)
2454 gfc_error ("Unexpected end of file in '%s'", gfc_source_file
);
2456 /* Memory cleanup. Move to "second to last". */
2457 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
2460 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
2463 longjmp (eof_buf
, 1);
2467 /* Parse the CONTAINS section of a derived type definition. */
2469 gfc_access gfc_typebound_default_access
;
2472 parse_derived_contains (void)
2475 bool seen_private
= false;
2476 bool seen_comps
= false;
2477 bool error_flag
= false;
2480 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2481 gcc_assert (gfc_current_block ());
2483 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
2485 if (gfc_current_block ()->attr
.sequence
)
2486 gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS"
2487 " section at %C", gfc_current_block ()->name
);
2488 if (gfc_current_block ()->attr
.is_bind_c
)
2489 gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
2490 " section at %C", gfc_current_block ()->name
);
2492 accept_statement (ST_CONTAINS
);
2493 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
2495 gfc_typebound_default_access
= ACCESS_PUBLIC
;
2501 st
= next_statement ();
2509 gfc_error ("Components in TYPE at %C must precede CONTAINS");
2513 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
2516 accept_statement (ST_PROCEDURE
);
2521 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
2524 accept_statement (ST_GENERIC
);
2529 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
2533 accept_statement (ST_FINAL
);
2541 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
2542 "at %C with empty CONTAINS section")))
2545 /* ST_END_TYPE is accepted by parse_derived after return. */
2549 if (!gfc_find_state (COMP_MODULE
))
2551 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2558 gfc_error ("PRIVATE statement at %C must precede procedure"
2565 gfc_error ("Duplicate PRIVATE statement at %C");
2569 accept_statement (ST_PRIVATE
);
2570 gfc_typebound_default_access
= ACCESS_PRIVATE
;
2571 seen_private
= true;
2575 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2579 gfc_error ("Already inside a CONTAINS block at %C");
2583 unexpected_statement (st
);
2591 reject_statement ();
2595 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2601 /* Parse a derived type. */
2604 parse_derived (void)
2606 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
2610 gfc_component
*c
, *lock_comp
= NULL
;
2612 accept_statement (ST_DERIVED_DECL
);
2613 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
2615 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
2622 while (compiling_type
)
2624 st
= next_statement ();
2632 accept_statement (st
);
2637 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
2644 if (!seen_component
)
2645 gfc_notify_std (GFC_STD_F2003
, "Derived type "
2646 "definition at %C without components");
2648 accept_statement (ST_END_TYPE
);
2652 if (!gfc_find_state (COMP_MODULE
))
2654 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2661 gfc_error ("PRIVATE statement at %C must precede "
2662 "structure components");
2667 gfc_error ("Duplicate PRIVATE statement at %C");
2669 s
.sym
->component_access
= ACCESS_PRIVATE
;
2671 accept_statement (ST_PRIVATE
);
2678 gfc_error ("SEQUENCE statement at %C must precede "
2679 "structure components");
2683 if (gfc_current_block ()->attr
.sequence
)
2684 gfc_warning ("SEQUENCE attribute at %C already specified in "
2689 gfc_error ("Duplicate SEQUENCE statement at %C");
2693 gfc_add_sequence (&gfc_current_block ()->attr
,
2694 gfc_current_block ()->name
, NULL
);
2698 gfc_notify_std (GFC_STD_F2003
,
2699 "CONTAINS block in derived type"
2700 " definition at %C");
2702 accept_statement (ST_CONTAINS
);
2703 parse_derived_contains ();
2707 unexpected_statement (st
);
2712 /* need to verify that all fields of the derived type are
2713 * interoperable with C if the type is declared to be bind(c)
2715 sym
= gfc_current_block ();
2716 for (c
= sym
->components
; c
; c
= c
->next
)
2718 bool coarray
, lock_type
, allocatable
, pointer
;
2719 coarray
= lock_type
= allocatable
= pointer
= false;
2721 /* Look for allocatable components. */
2722 if (c
->attr
.allocatable
2723 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2724 && CLASS_DATA (c
)->attr
.allocatable
)
2725 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
2726 && c
->ts
.u
.derived
->attr
.alloc_comp
))
2729 sym
->attr
.alloc_comp
= 1;
2732 /* Look for pointer components. */
2734 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2735 && CLASS_DATA (c
)->attr
.class_pointer
)
2736 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
2739 sym
->attr
.pointer_comp
= 1;
2742 /* Look for procedure pointer components. */
2743 if (c
->attr
.proc_pointer
2744 || (c
->ts
.type
== BT_DERIVED
2745 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
2746 sym
->attr
.proc_pointer_comp
= 1;
2748 /* Looking for coarray components. */
2749 if (c
->attr
.codimension
2750 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2751 && CLASS_DATA (c
)->attr
.codimension
))
2754 sym
->attr
.coarray_comp
= 1;
2757 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
2758 && !c
->attr
.pointer
)
2761 sym
->attr
.coarray_comp
= 1;
2764 /* Looking for lock_type components. */
2765 if ((c
->ts
.type
== BT_DERIVED
2766 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2767 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2768 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2769 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2770 == INTMOD_ISO_FORTRAN_ENV
2771 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2772 == ISOFORTRAN_LOCK_TYPE
)
2773 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
2774 && !allocatable
&& !pointer
))
2778 sym
->attr
.lock_comp
= 1;
2781 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2782 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2783 unless there are nondirect [allocatable or pointer] components
2784 involved (cf. 1.3.33.1 and 1.3.33.3). */
2786 if (pointer
&& !coarray
&& lock_type
)
2787 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2788 "codimension or be a subcomponent of a coarray, "
2789 "which is not possible as the component has the "
2790 "pointer attribute", c
->name
, &c
->loc
);
2791 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
2792 && c
->ts
.u
.derived
->attr
.lock_comp
)
2793 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2794 "of type LOCK_TYPE, which must have a codimension or be a "
2795 "subcomponent of a coarray", c
->name
, &c
->loc
);
2797 if (lock_type
&& allocatable
&& !coarray
)
2798 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
2799 "a codimension", c
->name
, &c
->loc
);
2800 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
2801 && c
->ts
.u
.derived
->attr
.lock_comp
)
2802 gfc_error ("Allocatable component %s at %L must have a codimension as "
2803 "it has a noncoarray subcomponent of type LOCK_TYPE",
2806 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
2807 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2808 "subcomponent of type LOCK_TYPE must have a codimension or "
2809 "be a subcomponent of a coarray. (Variables of type %s may "
2810 "not have a codimension as already a coarray "
2811 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
2813 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
2814 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2815 "subcomponent of type LOCK_TYPE must have a codimension or "
2816 "be a subcomponent of a coarray. (Variables of type %s may "
2817 "not have a codimension as %s at %L has a codimension or a "
2818 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
2819 sym
->name
, c
->name
, &c
->loc
);
2821 /* Look for private components. */
2822 if (sym
->component_access
== ACCESS_PRIVATE
2823 || c
->attr
.access
== ACCESS_PRIVATE
2824 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
2825 sym
->attr
.private_comp
= 1;
2828 if (!seen_component
)
2829 sym
->attr
.zero_comp
= 1;
2835 /* Parse an ENUM. */
2843 int seen_enumerator
= 0;
2845 push_state (&s
, COMP_ENUM
, gfc_new_block
);
2849 while (compiling_enum
)
2851 st
= next_statement ();
2859 seen_enumerator
= 1;
2860 accept_statement (st
);
2865 if (!seen_enumerator
)
2866 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2867 accept_statement (st
);
2871 gfc_free_enum_history ();
2872 unexpected_statement (st
);
2880 /* Parse an interface. We must be able to deal with the possibility
2881 of recursive interfaces. The parse_spec() subroutine is mutually
2882 recursive with parse_interface(). */
2884 static gfc_statement
parse_spec (gfc_statement
);
2887 parse_interface (void)
2889 gfc_compile_state new_state
= COMP_NONE
, current_state
;
2890 gfc_symbol
*prog_unit
, *sym
;
2891 gfc_interface_info save
;
2892 gfc_state_data s1
, s2
;
2895 accept_statement (ST_INTERFACE
);
2897 current_interface
.ns
= gfc_current_ns
;
2898 save
= current_interface
;
2900 sym
= (current_interface
.type
== INTERFACE_GENERIC
2901 || current_interface
.type
== INTERFACE_USER_OP
)
2902 ? gfc_new_block
: NULL
;
2904 push_state (&s1
, COMP_INTERFACE
, sym
);
2905 current_state
= COMP_NONE
;
2908 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
2910 st
= next_statement ();
2918 if (st
== ST_SUBROUTINE
)
2919 new_state
= COMP_SUBROUTINE
;
2920 else if (st
== ST_FUNCTION
)
2921 new_state
= COMP_FUNCTION
;
2922 if (gfc_new_block
->attr
.pointer
)
2924 gfc_new_block
->attr
.pointer
= 0;
2925 gfc_new_block
->attr
.proc_pointer
= 1;
2927 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
2928 gfc_new_block
->formal
, NULL
))
2930 reject_statement ();
2931 gfc_free_namespace (gfc_current_ns
);
2937 case ST_MODULE_PROC
: /* The module procedure matcher makes
2938 sure the context is correct. */
2939 accept_statement (st
);
2940 gfc_free_namespace (gfc_current_ns
);
2943 case ST_END_INTERFACE
:
2944 gfc_free_namespace (gfc_current_ns
);
2945 gfc_current_ns
= current_interface
.ns
;
2949 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2950 gfc_ascii_statement (st
));
2951 reject_statement ();
2952 gfc_free_namespace (gfc_current_ns
);
2957 /* Make sure that the generic name has the right attribute. */
2958 if (current_interface
.type
== INTERFACE_GENERIC
2959 && current_state
== COMP_NONE
)
2961 if (new_state
== COMP_FUNCTION
&& sym
)
2962 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
2963 else if (new_state
== COMP_SUBROUTINE
&& sym
)
2964 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
2966 current_state
= new_state
;
2969 if (current_interface
.type
== INTERFACE_ABSTRACT
)
2971 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
2972 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
2973 gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
2974 "cannot be the same as an intrinsic type",
2975 gfc_new_block
->name
);
2978 push_state (&s2
, new_state
, gfc_new_block
);
2979 accept_statement (st
);
2980 prog_unit
= gfc_new_block
;
2981 prog_unit
->formal_ns
= gfc_current_ns
;
2982 if (prog_unit
== prog_unit
->formal_ns
->proc_name
2983 && prog_unit
->ns
!= prog_unit
->formal_ns
)
2987 /* Read data declaration statements. */
2988 st
= parse_spec (ST_NONE
);
2990 /* Since the interface block does not permit an IMPLICIT statement,
2991 the default type for the function or the result must be taken
2992 from the formal namespace. */
2993 if (new_state
== COMP_FUNCTION
)
2995 if (prog_unit
->result
== prog_unit
2996 && prog_unit
->ts
.type
== BT_UNKNOWN
)
2997 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
2998 else if (prog_unit
->result
!= prog_unit
2999 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
3000 gfc_set_default_type (prog_unit
->result
, 1,
3001 prog_unit
->formal_ns
);
3004 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
3006 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
3007 gfc_ascii_statement (st
));
3008 reject_statement ();
3012 /* Add EXTERNAL attribute to function or subroutine. */
3013 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
3014 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
3016 current_interface
= save
;
3017 gfc_add_interface (prog_unit
);
3020 if (current_interface
.ns
3021 && current_interface
.ns
->proc_name
3022 && strcmp (current_interface
.ns
->proc_name
->name
,
3023 prog_unit
->name
) == 0)
3024 gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
3025 "enclosing procedure", prog_unit
->name
,
3026 ¤t_interface
.ns
->proc_name
->declared_at
);
3035 /* Associate function characteristics by going back to the function
3036 declaration and rematching the prefix. */
3039 match_deferred_characteristics (gfc_typespec
* ts
)
3042 match m
= MATCH_ERROR
;
3043 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3045 loc
= gfc_current_locus
;
3047 gfc_current_locus
= gfc_current_block ()->declared_at
;
3050 gfc_buffer_error (1);
3051 m
= gfc_match_prefix (ts
);
3052 gfc_buffer_error (0);
3054 if (ts
->type
== BT_DERIVED
)
3062 /* Only permit one go at the characteristic association. */
3066 /* Set the function locus correctly. If we have not found the
3067 function name, there is an error. */
3069 && gfc_match ("function% %n", name
) == MATCH_YES
3070 && strcmp (name
, gfc_current_block ()->name
) == 0)
3072 gfc_current_block ()->declared_at
= gfc_current_locus
;
3073 gfc_commit_symbols ();
3078 gfc_undo_symbols ();
3081 gfc_current_locus
=loc
;
3086 /* Check specification-expressions in the function result of the currently
3087 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
3088 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
3089 scope are not yet parsed so this has to be delayed up to parse_spec. */
3092 check_function_result_typed (void)
3094 gfc_typespec
* ts
= &gfc_current_ns
->proc_name
->result
->ts
;
3096 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
3097 gcc_assert (ts
->type
!= BT_UNKNOWN
);
3099 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
3100 /* TODO: Extend when KIND type parameters are implemented. */
3101 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
)
3102 gfc_expr_check_typed (ts
->u
.cl
->length
, gfc_current_ns
, true);
3106 /* Parse a set of specification statements. Returns the statement
3107 that doesn't fit. */
3109 static gfc_statement
3110 parse_spec (gfc_statement st
)
3113 bool function_result_typed
= false;
3114 bool bad_characteristic
= false;
3117 verify_st_order (&ss
, ST_NONE
, false);
3119 st
= next_statement ();
3121 /* If we are not inside a function or don't have a result specified so far,
3122 do nothing special about it. */
3123 if (gfc_current_state () != COMP_FUNCTION
)
3124 function_result_typed
= true;
3127 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
3130 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
3131 function_result_typed
= true;
3136 /* If we're inside a BLOCK construct, some statements are disallowed.
3137 Check this here. Attribute declaration statements like INTENT, OPTIONAL
3138 or VALUE are also disallowed, but they don't have a particular ST_*
3139 key so we have to check for them individually in their matcher routine. */
3140 if (gfc_current_state () == COMP_BLOCK
)
3144 case ST_IMPLICIT_NONE
:
3147 case ST_EQUIVALENCE
:
3148 case ST_STATEMENT_FUNCTION
:
3149 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
3150 gfc_ascii_statement (st
));
3151 reject_statement ();
3157 else if (gfc_current_state () == COMP_BLOCK_DATA
)
3158 /* Fortran 2008, C1116. */
3165 case ST_END_BLOCK_DATA
:
3167 case ST_EQUIVALENCE
:
3170 case ST_IMPLICIT_NONE
:
3171 case ST_DERIVED_DECL
:
3179 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
3180 gfc_ascii_statement (st
));
3181 reject_statement ();
3185 /* If we find a statement that can not be followed by an IMPLICIT statement
3186 (and thus we can expect to see none any further), type the function result
3187 if it has not yet been typed. Be careful not to give the END statement
3188 to verify_st_order! */
3189 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
3191 bool verify_now
= false;
3193 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
3198 verify_st_order (&dummyss
, ST_NONE
, false);
3199 verify_st_order (&dummyss
, st
, false);
3201 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
3207 check_function_result_typed ();
3208 function_result_typed
= true;
3217 case ST_IMPLICIT_NONE
:
3219 if (!function_result_typed
)
3221 check_function_result_typed ();
3222 function_result_typed
= true;
3228 case ST_DATA
: /* Not allowed in interfaces */
3229 if (gfc_current_state () == COMP_INTERFACE
)
3239 case ST_DERIVED_DECL
:
3242 if (!verify_st_order (&ss
, st
, false))
3244 reject_statement ();
3245 st
= next_statement ();
3255 case ST_DERIVED_DECL
:
3261 if (gfc_current_state () != COMP_MODULE
)
3263 gfc_error ("%s statement must appear in a MODULE",
3264 gfc_ascii_statement (st
));
3265 reject_statement ();
3269 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
3271 gfc_error ("%s statement at %C follows another accessibility "
3272 "specification", gfc_ascii_statement (st
));
3273 reject_statement ();
3277 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
3278 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3282 case ST_STATEMENT_FUNCTION
:
3283 if (gfc_current_state () == COMP_MODULE
)
3285 unexpected_statement (st
);
3293 accept_statement (st
);
3294 st
= next_statement ();
3298 accept_statement (st
);
3300 st
= next_statement ();
3303 case ST_GET_FCN_CHARACTERISTICS
:
3304 /* This statement triggers the association of a function's result
3306 ts
= &gfc_current_block ()->result
->ts
;
3307 if (match_deferred_characteristics (ts
) != MATCH_YES
)
3308 bad_characteristic
= true;
3310 st
= next_statement ();
3313 case ST_OACC_DECLARE
:
3314 if (!verify_st_order(&ss
, st
, false))
3316 reject_statement ();
3317 st
= next_statement ();
3320 if (gfc_state_stack
->ext
.oacc_declare_clauses
== NULL
)
3321 gfc_state_stack
->ext
.oacc_declare_clauses
= new_st
.ext
.omp_clauses
;
3322 accept_statement (st
);
3323 st
= next_statement ();
3330 /* If match_deferred_characteristics failed, then there is an error. */
3331 if (bad_characteristic
)
3333 ts
= &gfc_current_block ()->result
->ts
;
3334 if (ts
->type
!= BT_DERIVED
)
3335 gfc_error ("Bad kind expression for function '%s' at %L",
3336 gfc_current_block ()->name
,
3337 &gfc_current_block ()->declared_at
);
3339 gfc_error ("The type for function '%s' at %L is not accessible",
3340 gfc_current_block ()->name
,
3341 &gfc_current_block ()->declared_at
);
3343 gfc_current_block ()->ts
.kind
= 0;
3344 /* Keep the derived type; if it's bad, it will be discovered later. */
3345 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
3346 ts
->type
= BT_UNKNOWN
;
3353 /* Parse a WHERE block, (not a simple WHERE statement). */
3356 parse_where_block (void)
3358 int seen_empty_else
;
3363 accept_statement (ST_WHERE_BLOCK
);
3364 top
= gfc_state_stack
->tail
;
3366 push_state (&s
, COMP_WHERE
, gfc_new_block
);
3368 d
= add_statement ();
3369 d
->expr1
= top
->expr1
;
3375 seen_empty_else
= 0;
3379 st
= next_statement ();
3385 case ST_WHERE_BLOCK
:
3386 parse_where_block ();
3391 accept_statement (st
);
3395 if (seen_empty_else
)
3397 gfc_error ("ELSEWHERE statement at %C follows previous "
3398 "unmasked ELSEWHERE");
3399 reject_statement ();
3403 if (new_st
.expr1
== NULL
)
3404 seen_empty_else
= 1;
3406 d
= new_level (gfc_state_stack
->head
);
3408 d
->expr1
= new_st
.expr1
;
3410 accept_statement (st
);
3415 accept_statement (st
);
3419 gfc_error ("Unexpected %s statement in WHERE block at %C",
3420 gfc_ascii_statement (st
));
3421 reject_statement ();
3425 while (st
!= ST_END_WHERE
);
3431 /* Parse a FORALL block (not a simple FORALL statement). */
3434 parse_forall_block (void)
3440 accept_statement (ST_FORALL_BLOCK
);
3441 top
= gfc_state_stack
->tail
;
3443 push_state (&s
, COMP_FORALL
, gfc_new_block
);
3445 d
= add_statement ();
3446 d
->op
= EXEC_FORALL
;
3451 st
= next_statement ();
3456 case ST_POINTER_ASSIGNMENT
:
3459 accept_statement (st
);
3462 case ST_WHERE_BLOCK
:
3463 parse_where_block ();
3466 case ST_FORALL_BLOCK
:
3467 parse_forall_block ();
3471 accept_statement (st
);
3478 gfc_error ("Unexpected %s statement in FORALL block at %C",
3479 gfc_ascii_statement (st
));
3481 reject_statement ();
3485 while (st
!= ST_END_FORALL
);
3491 static gfc_statement
parse_executable (gfc_statement
);
3493 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
3496 parse_if_block (void)
3505 accept_statement (ST_IF_BLOCK
);
3507 top
= gfc_state_stack
->tail
;
3508 push_state (&s
, COMP_IF
, gfc_new_block
);
3510 new_st
.op
= EXEC_IF
;
3511 d
= add_statement ();
3513 d
->expr1
= top
->expr1
;
3519 st
= parse_executable (ST_NONE
);
3529 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
3530 "statement at %L", &else_locus
);
3532 reject_statement ();
3536 d
= new_level (gfc_state_stack
->head
);
3538 d
->expr1
= new_st
.expr1
;
3540 accept_statement (st
);
3547 gfc_error ("Duplicate ELSE statements at %L and %C",
3549 reject_statement ();
3554 else_locus
= gfc_current_locus
;
3556 d
= new_level (gfc_state_stack
->head
);
3559 accept_statement (st
);
3567 unexpected_statement (st
);
3571 while (st
!= ST_ENDIF
);
3574 accept_statement (st
);
3578 /* Parse a SELECT block. */
3581 parse_select_block (void)
3587 accept_statement (ST_SELECT_CASE
);
3589 cp
= gfc_state_stack
->tail
;
3590 push_state (&s
, COMP_SELECT
, gfc_new_block
);
3592 /* Make sure that the next statement is a CASE or END SELECT. */
3595 st
= next_statement ();
3598 if (st
== ST_END_SELECT
)
3600 /* Empty SELECT CASE is OK. */
3601 accept_statement (st
);
3608 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
3611 reject_statement ();
3614 /* At this point, we're got a nonempty select block. */
3615 cp
= new_level (cp
);
3618 accept_statement (st
);
3622 st
= parse_executable (ST_NONE
);
3629 cp
= new_level (gfc_state_stack
->head
);
3631 gfc_clear_new_st ();
3633 accept_statement (st
);
3639 /* Can't have an executable statement because of
3640 parse_executable(). */
3642 unexpected_statement (st
);
3646 while (st
!= ST_END_SELECT
);
3649 accept_statement (st
);
3653 /* Pop the current selector from the SELECT TYPE stack. */
3656 select_type_pop (void)
3658 gfc_select_type_stack
*old
= select_type_stack
;
3659 select_type_stack
= old
->prev
;
3664 /* Parse a SELECT TYPE construct (F03:R821). */
3667 parse_select_type_block (void)
3673 accept_statement (ST_SELECT_TYPE
);
3675 cp
= gfc_state_stack
->tail
;
3676 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
3678 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
3682 st
= next_statement ();
3685 if (st
== ST_END_SELECT
)
3686 /* Empty SELECT CASE is OK. */
3688 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
3691 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
3692 "following SELECT TYPE at %C");
3694 reject_statement ();
3697 /* At this point, we're got a nonempty select block. */
3698 cp
= new_level (cp
);
3701 accept_statement (st
);
3705 st
= parse_executable (ST_NONE
);
3713 cp
= new_level (gfc_state_stack
->head
);
3715 gfc_clear_new_st ();
3717 accept_statement (st
);
3723 /* Can't have an executable statement because of
3724 parse_executable(). */
3726 unexpected_statement (st
);
3730 while (st
!= ST_END_SELECT
);
3734 accept_statement (st
);
3735 gfc_current_ns
= gfc_current_ns
->parent
;
3740 /* Given a symbol, make sure it is not an iteration variable for a DO
3741 statement. This subroutine is called when the symbol is seen in a
3742 context that causes it to become redefined. If the symbol is an
3743 iterator, we generate an error message and return nonzero. */
3746 gfc_check_do_variable (gfc_symtree
*st
)
3750 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
3751 if (s
->do_variable
== st
)
3753 gfc_error_now("Variable '%s' at %C cannot be redefined inside "
3754 "loop beginning at %L", st
->name
, &s
->head
->loc
);
3762 /* Checks to see if the current statement label closes an enddo.
3763 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3764 an error) if it incorrectly closes an ENDDO. */
3767 check_do_closure (void)
3771 if (gfc_statement_label
== NULL
)
3774 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
3775 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
3779 return 0; /* No loops to close */
3781 if (p
->ext
.end_do_label
== gfc_statement_label
)
3783 if (p
== gfc_state_stack
)
3786 gfc_error ("End of nonblock DO statement at %C is within another block");
3790 /* At this point, the label doesn't terminate the innermost loop.
3791 Make sure it doesn't terminate another one. */
3792 for (; p
; p
= p
->previous
)
3793 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
3794 && p
->ext
.end_do_label
== gfc_statement_label
)
3796 gfc_error ("End of nonblock DO statement at %C is interwoven "
3797 "with another DO loop");
3805 /* Parse a series of contained program units. */
3807 static void parse_progunit (gfc_statement
);
3810 /* Parse a CRITICAL block. */
3813 parse_critical_block (void)
3816 gfc_state_data s
, *sd
;
3819 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
3820 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
3821 gfc_error_now (is_oacc (sd
)
3822 ? "CRITICAL block inside of OpenACC region at %C"
3823 : "CRITICAL block inside of OpenMP region at %C");
3825 s
.ext
.end_do_label
= new_st
.label1
;
3827 accept_statement (ST_CRITICAL
);
3828 top
= gfc_state_stack
->tail
;
3830 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
3832 d
= add_statement ();
3833 d
->op
= EXEC_CRITICAL
;
3838 st
= parse_executable (ST_NONE
);
3846 case ST_END_CRITICAL
:
3847 if (s
.ext
.end_do_label
!= NULL
3848 && s
.ext
.end_do_label
!= gfc_statement_label
)
3849 gfc_error_now ("Statement label in END CRITICAL at %C does not "
3850 "match CRITICAL label");
3852 if (gfc_statement_label
!= NULL
)
3854 new_st
.op
= EXEC_NOP
;
3860 unexpected_statement (st
);
3864 while (st
!= ST_END_CRITICAL
);
3867 accept_statement (st
);
3871 /* Set up the local namespace for a BLOCK construct. */
3874 gfc_build_block_ns (gfc_namespace
*parent_ns
)
3876 gfc_namespace
* my_ns
;
3877 static int numblock
= 1;
3879 my_ns
= gfc_get_namespace (parent_ns
, 1);
3880 my_ns
->construct_entities
= 1;
3882 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3883 code generation (so it must not be NULL).
3884 We set its recursive argument if our container procedure is recursive, so
3885 that local variables are accordingly placed on the stack when it
3886 will be necessary. */
3888 my_ns
->proc_name
= gfc_new_block
;
3892 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
3894 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
3895 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
3896 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
3897 my_ns
->proc_name
->name
, NULL
);
3899 gfc_commit_symbol (my_ns
->proc_name
);
3902 if (parent_ns
->proc_name
)
3903 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
3909 /* Parse a BLOCK construct. */
3912 parse_block_construct (void)
3914 gfc_namespace
* my_ns
;
3917 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
3919 my_ns
= gfc_build_block_ns (gfc_current_ns
);
3921 new_st
.op
= EXEC_BLOCK
;
3922 new_st
.ext
.block
.ns
= my_ns
;
3923 new_st
.ext
.block
.assoc
= NULL
;
3924 accept_statement (ST_BLOCK
);
3926 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
3927 gfc_current_ns
= my_ns
;
3929 parse_progunit (ST_NONE
);
3931 gfc_current_ns
= gfc_current_ns
->parent
;
3936 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
3937 behind the scenes with compiler-generated variables. */
3940 parse_associate (void)
3942 gfc_namespace
* my_ns
;
3945 gfc_association_list
* a
;
3947 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
3949 my_ns
= gfc_build_block_ns (gfc_current_ns
);
3951 new_st
.op
= EXEC_BLOCK
;
3952 new_st
.ext
.block
.ns
= my_ns
;
3953 gcc_assert (new_st
.ext
.block
.assoc
);
3955 /* Add all associate-names as BLOCK variables. Creating them is enough
3956 for now, they'll get their values during trans-* phase. */
3957 gfc_current_ns
= my_ns
;
3958 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
3962 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
3966 sym
->attr
.flavor
= FL_VARIABLE
;
3968 sym
->declared_at
= a
->where
;
3969 gfc_set_sym_referenced (sym
);
3971 /* Initialize the typespec. It is not available in all cases,
3972 however, as it may only be set on the target during resolution.
3973 Still, sometimes it helps to have it right now -- especially
3974 for parsing component references on the associate-name
3975 in case of association to a derived-type. */
3976 sym
->ts
= a
->target
->ts
;
3979 accept_statement (ST_ASSOCIATE
);
3980 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
3983 st
= parse_executable (ST_NONE
);
3990 accept_statement (st
);
3991 my_ns
->code
= gfc_state_stack
->head
;
3995 unexpected_statement (st
);
3999 gfc_current_ns
= gfc_current_ns
->parent
;
4004 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
4005 handled inside of parse_executable(), because they aren't really
4009 parse_do_block (void)
4018 s
.ext
.end_do_label
= new_st
.label1
;
4020 if (new_st
.ext
.iterator
!= NULL
)
4021 stree
= new_st
.ext
.iterator
->var
->symtree
;
4025 accept_statement (ST_DO
);
4027 top
= gfc_state_stack
->tail
;
4028 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
4031 s
.do_variable
= stree
;
4033 top
->block
= new_level (top
);
4034 top
->block
->op
= EXEC_DO
;
4037 st
= parse_executable (ST_NONE
);
4045 if (s
.ext
.end_do_label
!= NULL
4046 && s
.ext
.end_do_label
!= gfc_statement_label
)
4047 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
4050 if (gfc_statement_label
!= NULL
)
4052 new_st
.op
= EXEC_NOP
;
4057 case ST_IMPLIED_ENDDO
:
4058 /* If the do-stmt of this DO construct has a do-construct-name,
4059 the corresponding end-do must be an end-do-stmt (with a matching
4060 name, but in that case we must have seen ST_ENDDO first).
4061 We only complain about this in pedantic mode. */
4062 if (gfc_current_block () != NULL
)
4063 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
4064 &gfc_current_block()->declared_at
);
4069 unexpected_statement (st
);
4074 accept_statement (st
);
4078 /* Parse the statements of OpenMP do/parallel do. */
4080 static gfc_statement
4081 parse_omp_do (gfc_statement omp_st
)
4087 accept_statement (omp_st
);
4089 cp
= gfc_state_stack
->tail
;
4090 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4091 np
= new_level (cp
);
4097 st
= next_statement ();
4100 else if (st
== ST_DO
)
4103 unexpected_statement (st
);
4107 if (gfc_statement_label
!= NULL
4108 && gfc_state_stack
->previous
!= NULL
4109 && gfc_state_stack
->previous
->state
== COMP_DO
4110 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4118 there should be no !$OMP END DO. */
4120 return ST_IMPLIED_ENDDO
;
4123 check_do_closure ();
4126 st
= next_statement ();
4127 gfc_statement omp_end_st
= ST_OMP_END_DO
;
4130 case ST_OMP_DISTRIBUTE
: omp_end_st
= ST_OMP_END_DISTRIBUTE
; break;
4131 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4132 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4134 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4135 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4137 case ST_OMP_DISTRIBUTE_SIMD
:
4138 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4140 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
4141 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
4142 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
4143 case ST_OMP_PARALLEL_DO_SIMD
:
4144 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
4146 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
4147 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4148 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4150 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4151 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4153 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4154 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4156 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4157 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4159 case ST_OMP_TEAMS_DISTRIBUTE
:
4160 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4162 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4163 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4165 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4166 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4168 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4169 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4171 default: gcc_unreachable ();
4173 if (st
== omp_end_st
)
4175 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
4176 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4178 gcc_assert (new_st
.op
== EXEC_NOP
);
4179 gfc_clear_new_st ();
4180 gfc_commit_symbols ();
4181 gfc_warning_check ();
4182 st
= next_statement ();
4188 /* Parse the statements of OpenMP atomic directive. */
4190 static gfc_statement
4191 parse_omp_atomic (void)
4198 accept_statement (ST_OMP_ATOMIC
);
4200 cp
= gfc_state_stack
->tail
;
4201 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4202 np
= new_level (cp
);
4205 count
= 1 + ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4206 == GFC_OMP_ATOMIC_CAPTURE
);
4210 st
= next_statement ();
4213 else if (st
== ST_ASSIGNMENT
)
4215 accept_statement (st
);
4219 unexpected_statement (st
);
4224 st
= next_statement ();
4225 if (st
== ST_OMP_END_ATOMIC
)
4227 gfc_clear_new_st ();
4228 gfc_commit_symbols ();
4229 gfc_warning_check ();
4230 st
= next_statement ();
4232 else if ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4233 == GFC_OMP_ATOMIC_CAPTURE
)
4234 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
4239 /* Parse the statements of an OpenACC structured block. */
4242 parse_oacc_structured_block (gfc_statement acc_st
)
4244 gfc_statement st
, acc_end_st
;
4246 gfc_state_data s
, *sd
;
4248 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4249 if (sd
->state
== COMP_CRITICAL
)
4250 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4252 accept_statement (acc_st
);
4254 cp
= gfc_state_stack
->tail
;
4255 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4256 np
= new_level (cp
);
4261 case ST_OACC_PARALLEL
:
4262 acc_end_st
= ST_OACC_END_PARALLEL
;
4264 case ST_OACC_KERNELS
:
4265 acc_end_st
= ST_OACC_END_KERNELS
;
4268 acc_end_st
= ST_OACC_END_DATA
;
4270 case ST_OACC_HOST_DATA
:
4271 acc_end_st
= ST_OACC_END_HOST_DATA
;
4279 st
= parse_executable (ST_NONE
);
4282 else if (st
!= acc_end_st
)
4283 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
4284 reject_statement ();
4286 while (st
!= acc_end_st
);
4288 gcc_assert (new_st
.op
== EXEC_NOP
);
4290 gfc_clear_new_st ();
4291 gfc_commit_symbols ();
4292 gfc_warning_check ();
4296 /* Parse the statements of OpenACC loop/parallel loop/kernels loop. */
4298 static gfc_statement
4299 parse_oacc_loop (gfc_statement acc_st
)
4303 gfc_state_data s
, *sd
;
4305 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4306 if (sd
->state
== COMP_CRITICAL
)
4307 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4309 accept_statement (acc_st
);
4311 cp
= gfc_state_stack
->tail
;
4312 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4313 np
= new_level (cp
);
4319 st
= next_statement ();
4322 else if (st
== ST_DO
)
4326 gfc_error ("Expected DO loop at %C");
4327 reject_statement ();
4332 if (gfc_statement_label
!= NULL
4333 && gfc_state_stack
->previous
!= NULL
4334 && gfc_state_stack
->previous
->state
== COMP_DO
4335 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4338 return ST_IMPLIED_ENDDO
;
4341 check_do_closure ();
4344 st
= next_statement ();
4345 if (st
== ST_OACC_END_LOOP
)
4346 gfc_warning ("Redundant !$ACC END LOOP at %C");
4347 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
4348 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
4349 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
4351 gcc_assert (new_st
.op
== EXEC_NOP
);
4352 gfc_clear_new_st ();
4353 gfc_commit_symbols ();
4354 gfc_warning_check ();
4355 st
= next_statement ();
4361 /* Parse the statements of an OpenMP structured block. */
4364 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
4366 gfc_statement st
, omp_end_st
;
4370 accept_statement (omp_st
);
4372 cp
= gfc_state_stack
->tail
;
4373 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4374 np
= new_level (cp
);
4380 case ST_OMP_PARALLEL
:
4381 omp_end_st
= ST_OMP_END_PARALLEL
;
4383 case ST_OMP_PARALLEL_SECTIONS
:
4384 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
4386 case ST_OMP_SECTIONS
:
4387 omp_end_st
= ST_OMP_END_SECTIONS
;
4389 case ST_OMP_ORDERED
:
4390 omp_end_st
= ST_OMP_END_ORDERED
;
4392 case ST_OMP_CRITICAL
:
4393 omp_end_st
= ST_OMP_END_CRITICAL
;
4396 omp_end_st
= ST_OMP_END_MASTER
;
4399 omp_end_st
= ST_OMP_END_SINGLE
;
4402 omp_end_st
= ST_OMP_END_TARGET
;
4404 case ST_OMP_TARGET_DATA
:
4405 omp_end_st
= ST_OMP_END_TARGET_DATA
;
4407 case ST_OMP_TARGET_TEAMS
:
4408 omp_end_st
= ST_OMP_END_TARGET_TEAMS
;
4410 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4411 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4413 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4414 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4416 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4417 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4419 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4420 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4423 omp_end_st
= ST_OMP_END_TASK
;
4425 case ST_OMP_TASKGROUP
:
4426 omp_end_st
= ST_OMP_END_TASKGROUP
;
4429 omp_end_st
= ST_OMP_END_TEAMS
;
4431 case ST_OMP_TEAMS_DISTRIBUTE
:
4432 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4434 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4435 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4437 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4438 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4440 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4441 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4443 case ST_OMP_DISTRIBUTE
:
4444 omp_end_st
= ST_OMP_END_DISTRIBUTE
;
4446 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4447 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4449 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4450 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4452 case ST_OMP_DISTRIBUTE_SIMD
:
4453 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4455 case ST_OMP_WORKSHARE
:
4456 omp_end_st
= ST_OMP_END_WORKSHARE
;
4458 case ST_OMP_PARALLEL_WORKSHARE
:
4459 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
4467 if (workshare_stmts_only
)
4469 /* Inside of !$omp workshare, only
4472 where statements and constructs
4473 forall statements and constructs
4477 are allowed. For !$omp critical these
4478 restrictions apply recursively. */
4481 st
= next_statement ();
4492 accept_statement (st
);
4495 case ST_WHERE_BLOCK
:
4496 parse_where_block ();
4499 case ST_FORALL_BLOCK
:
4500 parse_forall_block ();
4503 case ST_OMP_PARALLEL
:
4504 case ST_OMP_PARALLEL_SECTIONS
:
4505 parse_omp_structured_block (st
, false);
4508 case ST_OMP_PARALLEL_WORKSHARE
:
4509 case ST_OMP_CRITICAL
:
4510 parse_omp_structured_block (st
, true);
4513 case ST_OMP_PARALLEL_DO
:
4514 case ST_OMP_PARALLEL_DO_SIMD
:
4515 st
= parse_omp_do (st
);
4519 st
= parse_omp_atomic ();
4530 st
= next_statement ();
4534 st
= parse_executable (ST_NONE
);
4537 else if (st
== ST_OMP_SECTION
4538 && (omp_st
== ST_OMP_SECTIONS
4539 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
4541 np
= new_level (np
);
4545 else if (st
!= omp_end_st
)
4546 unexpected_statement (st
);
4548 while (st
!= omp_end_st
);
4552 case EXEC_OMP_END_NOWAIT
:
4553 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4555 case EXEC_OMP_CRITICAL
:
4556 if (((cp
->ext
.omp_name
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
4557 || (new_st
.ext
.omp_name
!= NULL
4558 && strcmp (cp
->ext
.omp_name
, new_st
.ext
.omp_name
) != 0))
4559 gfc_error ("Name after !$omp critical and !$omp end critical does "
4561 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
4563 case EXEC_OMP_END_SINGLE
:
4564 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
4565 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
4566 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
4567 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
4575 gfc_clear_new_st ();
4576 gfc_commit_symbols ();
4577 gfc_warning_check ();
4582 /* Accept a series of executable statements. We return the first
4583 statement that doesn't fit to the caller. Any block statements are
4584 passed on to the correct handler, which usually passes the buck
4587 static gfc_statement
4588 parse_executable (gfc_statement st
)
4593 st
= next_statement ();
4597 close_flag
= check_do_closure ();
4602 case ST_END_PROGRAM
:
4605 case ST_END_FUNCTION
:
4610 case ST_END_SUBROUTINE
:
4615 case ST_SELECT_CASE
:
4616 gfc_error ("%s statement at %C cannot terminate a non-block "
4617 "DO loop", gfc_ascii_statement (st
));
4630 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
4631 "first executable statement");
4637 accept_statement (st
);
4638 if (close_flag
== 1)
4639 return ST_IMPLIED_ENDDO
;
4643 parse_block_construct ();
4654 case ST_SELECT_CASE
:
4655 parse_select_block ();
4658 case ST_SELECT_TYPE
:
4659 parse_select_type_block();
4664 if (check_do_closure () == 1)
4665 return ST_IMPLIED_ENDDO
;
4669 parse_critical_block ();
4672 case ST_WHERE_BLOCK
:
4673 parse_where_block ();
4676 case ST_FORALL_BLOCK
:
4677 parse_forall_block ();
4680 case ST_OACC_PARALLEL_LOOP
:
4681 case ST_OACC_KERNELS_LOOP
:
4683 st
= parse_oacc_loop (st
);
4684 if (st
== ST_IMPLIED_ENDDO
)
4688 case ST_OACC_PARALLEL
:
4689 case ST_OACC_KERNELS
:
4691 case ST_OACC_HOST_DATA
:
4692 parse_oacc_structured_block (st
);
4695 case ST_OMP_PARALLEL
:
4696 case ST_OMP_PARALLEL_SECTIONS
:
4697 case ST_OMP_SECTIONS
:
4698 case ST_OMP_ORDERED
:
4699 case ST_OMP_CRITICAL
:
4703 case ST_OMP_TARGET_DATA
:
4704 case ST_OMP_TARGET_TEAMS
:
4707 case ST_OMP_TASKGROUP
:
4708 parse_omp_structured_block (st
, false);
4711 case ST_OMP_WORKSHARE
:
4712 case ST_OMP_PARALLEL_WORKSHARE
:
4713 parse_omp_structured_block (st
, true);
4716 case ST_OMP_DISTRIBUTE
:
4717 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4718 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4719 case ST_OMP_DISTRIBUTE_SIMD
:
4721 case ST_OMP_DO_SIMD
:
4722 case ST_OMP_PARALLEL_DO
:
4723 case ST_OMP_PARALLEL_DO_SIMD
:
4725 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4726 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4727 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4728 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4729 case ST_OMP_TEAMS_DISTRIBUTE
:
4730 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4731 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4732 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4733 st
= parse_omp_do (st
);
4734 if (st
== ST_IMPLIED_ENDDO
)
4739 st
= parse_omp_atomic ();
4746 st
= next_statement ();
4751 /* Fix the symbols for sibling functions. These are incorrectly added to
4752 the child namespace as the parser didn't know about this procedure. */
4755 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
4759 gfc_symbol
*old_sym
;
4761 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
4763 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
4765 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
4766 goto fixup_contained
;
4768 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
4769 && sym
->attr
.generic
&& sym
->attr
.function
)
4770 ||(sym
->attr
.flavor
== FL_DERIVED
4771 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
4772 goto fixup_contained
;
4774 old_sym
= st
->n
.sym
;
4775 if (old_sym
->ns
== ns
4776 && !old_sym
->attr
.contained
4778 /* By 14.6.1.3, host association should be excluded
4779 for the following. */
4780 && !(old_sym
->attr
.external
4781 || (old_sym
->ts
.type
!= BT_UNKNOWN
4782 && !old_sym
->attr
.implicit_type
)
4783 || old_sym
->attr
.flavor
== FL_PARAMETER
4784 || old_sym
->attr
.use_assoc
4785 || old_sym
->attr
.in_common
4786 || old_sym
->attr
.in_equivalence
4787 || old_sym
->attr
.data
4788 || old_sym
->attr
.dummy
4789 || old_sym
->attr
.result
4790 || old_sym
->attr
.dimension
4791 || old_sym
->attr
.allocatable
4792 || old_sym
->attr
.intrinsic
4793 || old_sym
->attr
.generic
4794 || old_sym
->attr
.flavor
== FL_NAMELIST
4795 || old_sym
->attr
.flavor
== FL_LABEL
4796 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
4798 /* Replace it with the symbol from the parent namespace. */
4802 gfc_release_symbol (old_sym
);
4806 /* Do the same for any contained procedures. */
4807 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
4812 parse_contained (int module
)
4814 gfc_namespace
*ns
, *parent_ns
, *tmp
;
4815 gfc_state_data s1
, s2
;
4819 int contains_statements
= 0;
4822 push_state (&s1
, COMP_CONTAINS
, NULL
);
4823 parent_ns
= gfc_current_ns
;
4827 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
4829 gfc_current_ns
->sibling
= parent_ns
->contained
;
4830 parent_ns
->contained
= gfc_current_ns
;
4833 /* Process the next available statement. We come here if we got an error
4834 and rejected the last statement. */
4835 st
= next_statement ();
4844 contains_statements
= 1;
4845 accept_statement (st
);
4848 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
4851 /* For internal procedures, create/update the symbol in the
4852 parent namespace. */
4856 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
4857 gfc_error ("Contained procedure '%s' at %C is already "
4858 "ambiguous", gfc_new_block
->name
);
4861 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
4863 &gfc_new_block
->declared_at
))
4865 if (st
== ST_FUNCTION
)
4866 gfc_add_function (&sym
->attr
, sym
->name
,
4867 &gfc_new_block
->declared_at
);
4869 gfc_add_subroutine (&sym
->attr
, sym
->name
,
4870 &gfc_new_block
->declared_at
);
4874 gfc_commit_symbols ();
4877 sym
= gfc_new_block
;
4879 /* Mark this as a contained function, so it isn't replaced
4880 by other module functions. */
4881 sym
->attr
.contained
= 1;
4883 /* Set implicit_pure so that it can be reset if any of the
4884 tests for purity fail. This is used for some optimisation
4885 during translation. */
4886 if (!sym
->attr
.pure
)
4887 sym
->attr
.implicit_pure
= 1;
4889 parse_progunit (ST_NONE
);
4891 /* Fix up any sibling functions that refer to this one. */
4892 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
4893 /* Or refer to any of its alternate entry points. */
4894 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
4895 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
4897 gfc_current_ns
->code
= s2
.head
;
4898 gfc_current_ns
= parent_ns
;
4903 /* These statements are associated with the end of the host unit. */
4904 case ST_END_FUNCTION
:
4906 case ST_END_PROGRAM
:
4907 case ST_END_SUBROUTINE
:
4908 accept_statement (st
);
4909 gfc_current_ns
->code
= s1
.head
;
4913 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
4914 gfc_ascii_statement (st
));
4915 reject_statement ();
4921 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
4922 && st
!= ST_END_MODULE
&& st
!= ST_END_PROGRAM
);
4924 /* The first namespace in the list is guaranteed to not have
4925 anything (worthwhile) in it. */
4926 tmp
= gfc_current_ns
;
4927 gfc_current_ns
= parent_ns
;
4928 if (seen_error
&& tmp
->refs
> 1)
4929 gfc_free_namespace (tmp
);
4931 ns
= gfc_current_ns
->contained
;
4932 gfc_current_ns
->contained
= ns
->sibling
;
4933 gfc_free_namespace (ns
);
4936 if (!contains_statements
)
4937 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
4938 "FUNCTION or SUBROUTINE statement at %C");
4942 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
4945 parse_progunit (gfc_statement st
)
4950 st
= parse_spec (st
);
4957 /* This is not allowed within BLOCK! */
4958 if (gfc_current_state () != COMP_BLOCK
)
4963 accept_statement (st
);
4970 if (gfc_current_state () == COMP_FUNCTION
)
4971 gfc_check_function_type (gfc_current_ns
);
4976 st
= parse_executable (st
);
4984 /* This is not allowed within BLOCK! */
4985 if (gfc_current_state () != COMP_BLOCK
)
4990 accept_statement (st
);
4997 unexpected_statement (st
);
4998 reject_statement ();
4999 st
= next_statement ();
5005 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
5006 if (p
->state
== COMP_CONTAINS
)
5009 if (gfc_find_state (COMP_MODULE
) == true)
5014 gfc_error ("CONTAINS statement at %C is already in a contained "
5016 reject_statement ();
5017 st
= next_statement ();
5021 parse_contained (0);
5024 gfc_current_ns
->code
= gfc_state_stack
->head
;
5025 if (gfc_state_stack
->state
== COMP_PROGRAM
5026 || gfc_state_stack
->state
== COMP_MODULE
5027 || gfc_state_stack
->state
== COMP_SUBROUTINE
5028 || gfc_state_stack
->state
== COMP_FUNCTION
5029 || gfc_state_stack
->state
== COMP_BLOCK
)
5030 gfc_current_ns
->oacc_declare_clauses
5031 = gfc_state_stack
->ext
.oacc_declare_clauses
;
5035 /* Come here to complain about a global symbol already in use as
5039 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
5044 where
= &gfc_current_locus
;
5054 case GSYM_SUBROUTINE
:
5055 name
= "SUBROUTINE";
5060 case GSYM_BLOCK_DATA
:
5061 name
= "BLOCK DATA";
5067 gfc_internal_error ("gfc_global_used(): Bad type");
5071 if (sym
->binding_label
)
5072 gfc_error ("Global binding name '%s' at %L is already being used as a %s "
5073 "at %L", sym
->binding_label
, where
, name
, &sym
->where
);
5075 gfc_error ("Global name '%s' at %L is already being used as a %s at %L",
5076 sym
->name
, where
, name
, &sym
->where
);
5080 /* Parse a block data program unit. */
5083 parse_block_data (void)
5086 static locus blank_locus
;
5087 static int blank_block
=0;
5090 gfc_current_ns
->proc_name
= gfc_new_block
;
5091 gfc_current_ns
->is_block_data
= 1;
5093 if (gfc_new_block
== NULL
)
5096 gfc_error ("Blank BLOCK DATA at %C conflicts with "
5097 "prior BLOCK DATA at %L", &blank_locus
);
5101 blank_locus
= gfc_current_locus
;
5106 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5108 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
5109 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5112 s
->type
= GSYM_BLOCK_DATA
;
5113 s
->where
= gfc_new_block
->declared_at
;
5118 st
= parse_spec (ST_NONE
);
5120 while (st
!= ST_END_BLOCK_DATA
)
5122 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
5123 gfc_ascii_statement (st
));
5124 reject_statement ();
5125 st
= next_statement ();
5130 /* Parse a module subprogram. */
5139 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5140 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
5141 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5144 s
->type
= GSYM_MODULE
;
5145 s
->where
= gfc_new_block
->declared_at
;
5149 st
= parse_spec (ST_NONE
);
5159 parse_contained (1);
5163 accept_statement (st
);
5167 gfc_error ("Unexpected %s statement in MODULE at %C",
5168 gfc_ascii_statement (st
));
5171 reject_statement ();
5172 st
= next_statement ();
5176 /* Make sure not to free the namespace twice on error. */
5178 s
->ns
= gfc_current_ns
;
5182 /* Add a procedure name to the global symbol table. */
5185 add_global_procedure (bool sub
)
5189 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5190 name is a global identifier. */
5191 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5193 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5196 || (s
->type
!= GSYM_UNKNOWN
5197 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5199 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5200 /* Silence follow-up errors. */
5201 gfc_new_block
->binding_label
= NULL
;
5205 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5206 s
->sym_name
= gfc_new_block
->name
;
5207 s
->where
= gfc_new_block
->declared_at
;
5209 s
->ns
= gfc_current_ns
;
5213 /* Don't add the symbol multiple times. */
5214 if (gfc_new_block
->binding_label
5215 && (!gfc_notification_std (GFC_STD_F2008
)
5216 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
5218 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
);
5221 || (s
->type
!= GSYM_UNKNOWN
5222 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5224 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5225 /* Silence follow-up errors. */
5226 gfc_new_block
->binding_label
= NULL
;
5230 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5231 s
->sym_name
= gfc_new_block
->name
;
5232 s
->binding_label
= gfc_new_block
->binding_label
;
5233 s
->where
= gfc_new_block
->declared_at
;
5235 s
->ns
= gfc_current_ns
;
5241 /* Add a program to the global symbol table. */
5244 add_global_program (void)
5248 if (gfc_new_block
== NULL
)
5250 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5252 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
5253 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5256 s
->type
= GSYM_PROGRAM
;
5257 s
->where
= gfc_new_block
->declared_at
;
5259 s
->ns
= gfc_current_ns
;
5264 /* Resolve all the program units. */
5266 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
5268 gfc_free_dt_list ();
5269 gfc_current_ns
= gfc_global_ns_list
;
5270 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5272 if (gfc_current_ns
->proc_name
5273 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5274 continue; /* Already resolved. */
5276 if (gfc_current_ns
->proc_name
)
5277 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5278 gfc_resolve (gfc_current_ns
);
5279 gfc_current_ns
->derived_types
= gfc_derived_types
;
5280 gfc_derived_types
= NULL
;
5286 clean_up_modules (gfc_gsymbol
*gsym
)
5291 clean_up_modules (gsym
->left
);
5292 clean_up_modules (gsym
->right
);
5294 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
5297 gfc_current_ns
= gsym
->ns
;
5298 gfc_derived_types
= gfc_current_ns
->derived_types
;
5305 /* Translate all the program units. This could be in a different order
5306 to resolution if there are forward references in the file. */
5308 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
5312 gfc_current_ns
= gfc_global_ns_list
;
5313 gfc_get_errors (NULL
, &errors
);
5315 /* We first translate all modules to make sure that later parts
5316 of the program can use the decl. Then we translate the nonmodules. */
5318 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5320 if (!gfc_current_ns
->proc_name
5321 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5324 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5325 gfc_derived_types
= gfc_current_ns
->derived_types
;
5326 gfc_generate_module_code (gfc_current_ns
);
5327 gfc_current_ns
->translated
= 1;
5330 gfc_current_ns
= gfc_global_ns_list
;
5331 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5333 if (gfc_current_ns
->proc_name
5334 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5337 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5338 gfc_derived_types
= gfc_current_ns
->derived_types
;
5339 gfc_generate_code (gfc_current_ns
);
5340 gfc_current_ns
->translated
= 1;
5343 /* Clean up all the namespaces after translation. */
5344 gfc_current_ns
= gfc_global_ns_list
;
5345 for (;gfc_current_ns
;)
5349 if (gfc_current_ns
->proc_name
5350 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5352 gfc_current_ns
= gfc_current_ns
->sibling
;
5356 ns
= gfc_current_ns
->sibling
;
5357 gfc_derived_types
= gfc_current_ns
->derived_types
;
5359 gfc_current_ns
= ns
;
5362 clean_up_modules (gfc_gsym_root
);
5366 /* Top level parser. */
5369 gfc_parse_file (void)
5371 int seen_program
, errors_before
, errors
;
5372 gfc_state_data top
, s
;
5375 gfc_namespace
*next
;
5377 gfc_start_source_files ();
5379 top
.state
= COMP_NONE
;
5381 top
.previous
= NULL
;
5382 top
.head
= top
.tail
= NULL
;
5383 top
.do_variable
= NULL
;
5385 gfc_state_stack
= &top
;
5387 gfc_clear_new_st ();
5389 gfc_statement_label
= NULL
;
5391 if (setjmp (eof_buf
))
5392 return false; /* Come here on unexpected EOF */
5394 /* Prepare the global namespace that will contain the
5396 gfc_global_ns_list
= next
= NULL
;
5401 /* Exit early for empty files. */
5407 st
= next_statement ();
5416 goto duplicate_main
;
5418 prog_locus
= gfc_current_locus
;
5420 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
5421 main_program_symbol(gfc_current_ns
, gfc_new_block
->name
);
5422 accept_statement (st
);
5423 add_global_program ();
5424 parse_progunit (ST_NONE
);
5429 add_global_procedure (true);
5430 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
5431 accept_statement (st
);
5432 parse_progunit (ST_NONE
);
5437 add_global_procedure (false);
5438 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
5439 accept_statement (st
);
5440 parse_progunit (ST_NONE
);
5445 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
5446 accept_statement (st
);
5447 parse_block_data ();
5451 push_state (&s
, COMP_MODULE
, gfc_new_block
);
5452 accept_statement (st
);
5454 gfc_get_errors (NULL
, &errors_before
);
5458 /* Anything else starts a nameless main program block. */
5461 goto duplicate_main
;
5463 prog_locus
= gfc_current_locus
;
5465 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
5466 main_program_symbol (gfc_current_ns
, "MAIN__");
5467 parse_progunit (st
);
5472 /* Handle the non-program units. */
5473 gfc_current_ns
->code
= s
.head
;
5475 gfc_resolve (gfc_current_ns
);
5477 /* Dump the parse tree if requested. */
5478 if (gfc_option
.dump_fortran_original
)
5479 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
5481 gfc_get_errors (NULL
, &errors
);
5482 if (s
.state
== COMP_MODULE
)
5484 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
5485 gfc_current_ns
->derived_types
= gfc_derived_types
;
5486 gfc_derived_types
= NULL
;
5492 gfc_generate_code (gfc_current_ns
);
5500 /* The main program and non-contained procedures are put
5501 in the global namespace list, so that they can be processed
5502 later and all their interfaces resolved. */
5503 gfc_current_ns
->code
= s
.head
;
5506 for (; next
->sibling
; next
= next
->sibling
)
5508 next
->sibling
= gfc_current_ns
;
5511 gfc_global_ns_list
= gfc_current_ns
;
5513 next
= gfc_current_ns
;
5520 /* Do the resolution. */
5521 resolve_all_program_units (gfc_global_ns_list
);
5523 /* Do the parse tree dump. */
5525 = gfc_option
.dump_fortran_original
? gfc_global_ns_list
: NULL
;
5527 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5528 if (!gfc_current_ns
->proc_name
5529 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5531 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
5532 fputs ("------------------------------------------\n\n", stdout
);
5535 /* Do the translation. */
5536 translate_all_program_units (gfc_global_ns_list
);
5538 gfc_end_source_files ();
5542 /* If we see a duplicate main program, shut down. If the second
5543 instance is an implied main program, i.e. data decls or executable
5544 statements, we're in for lots of errors. */
5545 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
5546 reject_statement ();
5551 /* Return true if this state data represents an OpenACC region. */
5553 is_oacc (gfc_state_data
*sd
)
5555 switch (sd
->construct
->op
)
5557 case EXEC_OACC_PARALLEL_LOOP
:
5558 case EXEC_OACC_PARALLEL
:
5559 case EXEC_OACC_KERNELS_LOOP
:
5560 case EXEC_OACC_KERNELS
:
5561 case EXEC_OACC_DATA
:
5562 case EXEC_OACC_HOST_DATA
:
5563 case EXEC_OACC_LOOP
:
5564 case EXEC_OACC_UPDATE
:
5565 case EXEC_OACC_WAIT
:
5566 case EXEC_OACC_CACHE
:
5567 case EXEC_OACC_ENTER_DATA
:
5568 case EXEC_OACC_EXIT_DATA
: