2 Copyright (C) 2000-2017 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/>. */
23 #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_buffer old_error
;
112 gfc_push_error (&old_error
);
113 gfc_buffer_error (false);
115 gfc_buffer_error (true);
116 gfc_pop_error (&old_error
);
117 gfc_commit_symbols ();
118 gfc_warning_check ();
119 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
120 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
121 last_was_use_stmt
= false;
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
);
193 match ("automatic", gfc_match_automatic
, ST_ATTR_DECL
);
197 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
201 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
202 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
206 match ("data", gfc_match_data
, ST_DATA
);
207 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
211 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
212 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
213 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
214 match ("external", gfc_match_external
, ST_ATTR_DECL
);
218 match ("format", gfc_match_format
, ST_FORMAT
);
225 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
226 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
227 match ("interface", gfc_match_interface
, ST_INTERFACE
);
228 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
229 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
236 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
240 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
244 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
245 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
246 if (gfc_match_private (&st
) == MATCH_YES
)
248 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
249 if (gfc_match_public (&st
) == MATCH_YES
)
251 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
258 match ("save", gfc_match_save
, ST_ATTR_DECL
);
259 match ("static", gfc_match_static
, ST_ATTR_DECL
);
260 match ("structure", gfc_match_structure_decl
, ST_STRUCTURE_DECL
);
264 match ("target", gfc_match_target
, ST_ATTR_DECL
);
265 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
272 match ("value", gfc_match_value
, ST_ATTR_DECL
);
273 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
280 /* This is not a specification statement. See if any of the matchers
281 has stored an error message of some sort. */
285 gfc_buffer_error (false);
286 gfc_current_locus
= old_locus
;
288 return ST_GET_FCN_CHARACTERISTICS
;
291 static bool in_specification_block
;
293 /* This is the primary 'decode_statement'. */
295 decode_statement (void)
302 gfc_enforce_clean_symbol_state ();
304 gfc_clear_error (); /* Clear any pending errors. */
305 gfc_clear_warning (); /* Clear any pending warnings. */
307 gfc_matching_function
= false;
309 if (gfc_match_eos () == MATCH_YES
)
312 if (gfc_current_state () == COMP_FUNCTION
313 && gfc_current_block ()->result
->ts
.kind
== -1)
314 return decode_specification_statement ();
316 old_locus
= gfc_current_locus
;
318 c
= gfc_peek_ascii_char ();
322 if (match_word ("use", gfc_match_use
, &old_locus
) == MATCH_YES
)
324 last_was_use_stmt
= true;
328 undo_new_statement ();
331 if (last_was_use_stmt
)
334 /* Try matching a data declaration or function declaration. The
335 input "REALFUNCTIONA(N)" can mean several things in different
336 contexts, so it (and its relatives) get special treatment. */
338 if (gfc_current_state () == COMP_NONE
339 || gfc_current_state () == COMP_INTERFACE
340 || gfc_current_state () == COMP_CONTAINS
)
342 gfc_matching_function
= true;
343 m
= gfc_match_function_decl ();
346 else if (m
== MATCH_ERROR
)
350 gfc_current_locus
= old_locus
;
352 gfc_matching_function
= false;
354 /* Legacy parameter statements are ambiguous with assignments so try parameter
356 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
358 /* Match statements whose error messages are meant to be overwritten
359 by something better. */
361 match (NULL
, gfc_match_assignment
, ST_ASSIGNMENT
);
362 match (NULL
, gfc_match_pointer_assignment
, ST_POINTER_ASSIGNMENT
);
364 if (in_specification_block
)
366 m
= match_word (NULL
, gfc_match_st_function
, &old_locus
);
368 return ST_STATEMENT_FUNCTION
;
371 if (!(in_specification_block
&& m
== MATCH_ERROR
))
373 match (NULL
, gfc_match_ptr_fcn_assign
, ST_ASSIGNMENT
);
376 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
377 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
379 /* Try to match a subroutine statement, which has the same optional
380 prefixes that functions can have. */
382 if (gfc_match_subroutine () == MATCH_YES
)
383 return ST_SUBROUTINE
;
385 gfc_current_locus
= old_locus
;
387 if (gfc_match_submod_proc () == MATCH_YES
)
389 if (gfc_new_block
->attr
.subroutine
)
390 return ST_SUBROUTINE
;
391 else if (gfc_new_block
->attr
.function
)
395 gfc_current_locus
= old_locus
;
397 /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
398 statements, which might begin with a block label. The match functions for
399 these statements are unusual in that their keyword is not seen before
400 the matcher is called. */
402 if (gfc_match_if (&st
) == MATCH_YES
)
405 gfc_current_locus
= old_locus
;
407 if (gfc_match_where (&st
) == MATCH_YES
)
410 gfc_current_locus
= old_locus
;
412 if (gfc_match_forall (&st
) == MATCH_YES
)
415 gfc_current_locus
= old_locus
;
417 /* Try to match TYPE as an alias for PRINT. */
418 if (gfc_match_type (&st
) == MATCH_YES
)
421 gfc_current_locus
= old_locus
;
423 match (NULL
, gfc_match_do
, ST_DO
);
424 match (NULL
, gfc_match_block
, ST_BLOCK
);
425 match (NULL
, gfc_match_associate
, ST_ASSOCIATE
);
426 match (NULL
, gfc_match_critical
, ST_CRITICAL
);
427 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
428 match (NULL
, gfc_match_select_type
, ST_SELECT_TYPE
);
430 /* General statement matching: Instead of testing every possible
431 statement, we eliminate most possibilities by peeking at the
437 match ("abstract% interface", gfc_match_abstract_interface
,
439 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
440 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
441 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
442 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
443 match ("automatic", gfc_match_automatic
, ST_ATTR_DECL
);
447 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
448 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
449 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
453 match ("call", gfc_match_call
, ST_CALL
);
454 match ("close", gfc_match_close
, ST_CLOSE
);
455 match ("continue", gfc_match_continue
, ST_CONTINUE
);
456 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
457 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
458 match ("case", gfc_match_case
, ST_CASE
);
459 match ("common", gfc_match_common
, ST_COMMON
);
460 match ("contains", gfc_match_eos
, ST_CONTAINS
);
461 match ("class", gfc_match_class_is
, ST_CLASS_IS
);
462 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
466 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
467 match ("data", gfc_match_data
, ST_DATA
);
468 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
472 match ("end file", gfc_match_endfile
, ST_END_FILE
);
473 match ("exit", gfc_match_exit
, ST_EXIT
);
474 match ("else", gfc_match_else
, ST_ELSE
);
475 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
476 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
477 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
);
478 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
480 if (gfc_match_end (&st
) == MATCH_YES
)
483 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
484 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
485 match ("external", gfc_match_external
, ST_ATTR_DECL
);
486 match ("event post", gfc_match_event_post
, ST_EVENT_POST
);
487 match ("event wait", gfc_match_event_wait
, ST_EVENT_WAIT
);
491 match ("fail image", gfc_match_fail_image
, ST_FAIL_IMAGE
);
492 match ("final", gfc_match_final_decl
, ST_FINAL
);
493 match ("flush", gfc_match_flush
, ST_FLUSH
);
494 match ("format", gfc_match_format
, ST_FORMAT
);
498 match ("generic", gfc_match_generic
, ST_GENERIC
);
499 match ("go to", gfc_match_goto
, ST_GOTO
);
503 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
504 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
505 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
506 match ("import", gfc_match_import
, ST_IMPORT
);
507 match ("interface", gfc_match_interface
, ST_INTERFACE
);
508 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
509 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
513 match ("lock", gfc_match_lock
, ST_LOCK
);
517 match ("map", gfc_match_map
, ST_MAP
);
518 match ("module% procedure", gfc_match_modproc
, ST_MODULE_PROC
);
519 match ("module", gfc_match_module
, ST_MODULE
);
523 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
524 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
528 match ("open", gfc_match_open
, ST_OPEN
);
529 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
533 match ("print", gfc_match_print
, ST_WRITE
);
534 match ("pause", gfc_match_pause
, ST_PAUSE
);
535 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
536 if (gfc_match_private (&st
) == MATCH_YES
)
538 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
539 match ("program", gfc_match_program
, ST_PROGRAM
);
540 if (gfc_match_public (&st
) == MATCH_YES
)
542 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
546 match ("read", gfc_match_read
, ST_READ
);
547 match ("return", gfc_match_return
, ST_RETURN
);
548 match ("rewind", gfc_match_rewind
, ST_REWIND
);
552 match ("structure", gfc_match_structure_decl
, ST_STRUCTURE_DECL
);
553 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
554 match ("stop", gfc_match_stop
, ST_STOP
);
555 match ("save", gfc_match_save
, ST_ATTR_DECL
);
556 match ("static", gfc_match_static
, ST_ATTR_DECL
);
557 match ("submodule", gfc_match_submodule
, ST_SUBMODULE
);
558 match ("sync all", gfc_match_sync_all
, ST_SYNC_ALL
);
559 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
560 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
564 match ("target", gfc_match_target
, ST_ATTR_DECL
);
565 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
566 match ("type is", gfc_match_type_is
, ST_TYPE_IS
);
570 match ("union", gfc_match_union
, ST_UNION
);
571 match ("unlock", gfc_match_unlock
, ST_UNLOCK
);
575 match ("value", gfc_match_value
, ST_ATTR_DECL
);
576 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
580 match ("wait", gfc_match_wait
, ST_WAIT
);
581 match ("write", gfc_match_write
, ST_WRITE
);
585 /* All else has failed, so give up. See if any of the matchers has
586 stored an error message of some sort. */
588 if (!gfc_error_check ())
589 gfc_error_now ("Unclassifiable statement at %C");
593 gfc_error_recovery ();
598 /* Like match and if spec_only, goto do_spec_only without actually
600 #define matcha(keyword, subr, st) \
602 if (spec_only && gfc_match (keyword) == MATCH_YES) \
604 else if (match_word (keyword, subr, &old_locus) \
608 undo_new_statement (); \
612 decode_oacc_directive (void)
616 bool spec_only
= false;
618 gfc_enforce_clean_symbol_state ();
620 gfc_clear_error (); /* Clear any pending errors. */
621 gfc_clear_warning (); /* Clear any pending warnings. */
625 gfc_error_now ("OpenACC directives at %C may not appear in PURE "
627 gfc_error_recovery ();
631 if (gfc_current_state () == COMP_FUNCTION
632 && gfc_current_block ()->result
->ts
.kind
== -1)
635 gfc_unset_implicit_pure (NULL
);
637 old_locus
= gfc_current_locus
;
639 /* General OpenACC directive matching: Instead of testing every possible
640 statement, we eliminate most possibilities by peeking at the
643 c
= gfc_peek_ascii_char ();
648 matcha ("atomic", gfc_match_oacc_atomic
, ST_OACC_ATOMIC
);
651 matcha ("cache", gfc_match_oacc_cache
, ST_OACC_CACHE
);
654 matcha ("data", gfc_match_oacc_data
, ST_OACC_DATA
);
655 match ("declare", gfc_match_oacc_declare
, ST_OACC_DECLARE
);
658 matcha ("end atomic", gfc_match_omp_eos
, ST_OACC_END_ATOMIC
);
659 matcha ("end data", gfc_match_omp_eos
, ST_OACC_END_DATA
);
660 matcha ("end host_data", gfc_match_omp_eos
, ST_OACC_END_HOST_DATA
);
661 matcha ("end kernels loop", gfc_match_omp_eos
, ST_OACC_END_KERNELS_LOOP
);
662 matcha ("end kernels", gfc_match_omp_eos
, ST_OACC_END_KERNELS
);
663 matcha ("end loop", gfc_match_omp_eos
, ST_OACC_END_LOOP
);
664 matcha ("end parallel loop", gfc_match_omp_eos
,
665 ST_OACC_END_PARALLEL_LOOP
);
666 matcha ("end parallel", gfc_match_omp_eos
, ST_OACC_END_PARALLEL
);
667 matcha ("enter data", gfc_match_oacc_enter_data
, ST_OACC_ENTER_DATA
);
668 matcha ("exit data", gfc_match_oacc_exit_data
, ST_OACC_EXIT_DATA
);
671 matcha ("host_data", gfc_match_oacc_host_data
, ST_OACC_HOST_DATA
);
674 matcha ("parallel loop", gfc_match_oacc_parallel_loop
,
675 ST_OACC_PARALLEL_LOOP
);
676 matcha ("parallel", gfc_match_oacc_parallel
, ST_OACC_PARALLEL
);
679 matcha ("kernels loop", gfc_match_oacc_kernels_loop
,
680 ST_OACC_KERNELS_LOOP
);
681 matcha ("kernels", gfc_match_oacc_kernels
, ST_OACC_KERNELS
);
684 matcha ("loop", gfc_match_oacc_loop
, ST_OACC_LOOP
);
687 match ("routine", gfc_match_oacc_routine
, ST_OACC_ROUTINE
);
690 matcha ("update", gfc_match_oacc_update
, ST_OACC_UPDATE
);
693 matcha ("wait", gfc_match_oacc_wait
, ST_OACC_WAIT
);
697 /* Directive not found or stored an error message.
698 Check and give up. */
700 if (gfc_error_check () == 0)
701 gfc_error_now ("Unclassifiable OpenACC directive at %C");
705 gfc_error_recovery ();
712 gfc_buffer_error (false);
713 gfc_current_locus
= old_locus
;
714 return ST_GET_FCN_CHARACTERISTICS
;
717 /* Like match, but set a flag simd_matched if keyword matched
718 and if spec_only, goto do_spec_only without actually matching. */
719 #define matchs(keyword, subr, st) \
721 if (spec_only && gfc_match (keyword) == MATCH_YES) \
723 if (match_word_omp_simd (keyword, subr, &old_locus, \
724 &simd_matched) == MATCH_YES) \
730 undo_new_statement (); \
733 /* Like match, but don't match anything if not -fopenmp
734 and if spec_only, goto do_spec_only without actually matching. */
735 #define matcho(keyword, subr, st) \
739 else if (spec_only && gfc_match (keyword) == MATCH_YES) \
741 else if (match_word (keyword, subr, &old_locus) \
748 undo_new_statement (); \
751 /* Like match, but set a flag simd_matched if keyword matched. */
752 #define matchds(keyword, subr, st) \
754 if (match_word_omp_simd (keyword, subr, &old_locus, \
755 &simd_matched) == MATCH_YES) \
761 undo_new_statement (); \
764 /* Like match, but don't match anything if not -fopenmp. */
765 #define matchdo(keyword, subr, st) \
769 else if (match_word (keyword, subr, &old_locus) \
776 undo_new_statement (); \
780 decode_omp_directive (void)
784 bool simd_matched
= false;
785 bool spec_only
= false;
786 gfc_statement ret
= ST_NONE
;
789 gfc_enforce_clean_symbol_state ();
791 gfc_clear_error (); /* Clear any pending errors. */
792 gfc_clear_warning (); /* Clear any pending warnings. */
794 if (gfc_current_state () == COMP_FUNCTION
795 && gfc_current_block ()->result
->ts
.kind
== -1)
798 old_locus
= gfc_current_locus
;
800 /* General OpenMP directive matching: Instead of testing every possible
801 statement, we eliminate most possibilities by peeking at the
804 c
= gfc_peek_ascii_char ();
806 /* match is for directives that should be recognized only if
807 -fopenmp, matchs for directives that should be recognized
808 if either -fopenmp or -fopenmp-simd.
809 Handle only the directives allowed in PURE/ELEMENTAL procedures
810 first (those also shall not turn off implicit pure). */
814 matchds ("declare simd", gfc_match_omp_declare_simd
,
815 ST_OMP_DECLARE_SIMD
);
816 matchdo ("declare target", gfc_match_omp_declare_target
,
817 ST_OMP_DECLARE_TARGET
);
820 matchs ("simd", gfc_match_omp_simd
, ST_OMP_SIMD
);
825 if (flag_openmp
&& gfc_pure (NULL
))
827 gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET "
828 "at %C may not appear in PURE or ELEMENTAL procedures");
829 gfc_error_recovery ();
833 /* match is for directives that should be recognized only if
834 -fopenmp, matchs for directives that should be recognized
835 if either -fopenmp or -fopenmp-simd. */
839 matcho ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
842 matcho ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
845 matcho ("cancellation% point", gfc_match_omp_cancellation_point
,
846 ST_OMP_CANCELLATION_POINT
);
847 matcho ("cancel", gfc_match_omp_cancel
, ST_OMP_CANCEL
);
848 matcho ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
851 matchds ("declare reduction", gfc_match_omp_declare_reduction
,
852 ST_OMP_DECLARE_REDUCTION
);
853 matchs ("distribute parallel do simd",
854 gfc_match_omp_distribute_parallel_do_simd
,
855 ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
);
856 matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do
,
857 ST_OMP_DISTRIBUTE_PARALLEL_DO
);
858 matchs ("distribute simd", gfc_match_omp_distribute_simd
,
859 ST_OMP_DISTRIBUTE_SIMD
);
860 matcho ("distribute", gfc_match_omp_distribute
, ST_OMP_DISTRIBUTE
);
861 matchs ("do simd", gfc_match_omp_do_simd
, ST_OMP_DO_SIMD
);
862 matcho ("do", gfc_match_omp_do
, ST_OMP_DO
);
865 matcho ("end atomic", gfc_match_omp_eos
, ST_OMP_END_ATOMIC
);
866 matcho ("end critical", gfc_match_omp_end_critical
, ST_OMP_END_CRITICAL
);
867 matchs ("end distribute parallel do simd", gfc_match_omp_eos
,
868 ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
);
869 matcho ("end distribute parallel do", gfc_match_omp_eos
,
870 ST_OMP_END_DISTRIBUTE_PARALLEL_DO
);
871 matchs ("end distribute simd", gfc_match_omp_eos
,
872 ST_OMP_END_DISTRIBUTE_SIMD
);
873 matcho ("end distribute", gfc_match_omp_eos
, ST_OMP_END_DISTRIBUTE
);
874 matchs ("end do simd", gfc_match_omp_end_nowait
, ST_OMP_END_DO_SIMD
);
875 matcho ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
876 matchs ("end simd", gfc_match_omp_eos
, ST_OMP_END_SIMD
);
877 matcho ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
878 matchs ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
879 matchs ("end parallel do simd", gfc_match_omp_eos
,
880 ST_OMP_END_PARALLEL_DO_SIMD
);
881 matcho ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
882 matcho ("end parallel sections", gfc_match_omp_eos
,
883 ST_OMP_END_PARALLEL_SECTIONS
);
884 matcho ("end parallel workshare", gfc_match_omp_eos
,
885 ST_OMP_END_PARALLEL_WORKSHARE
);
886 matcho ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
887 matcho ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
888 matcho ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
889 matcho ("end target data", gfc_match_omp_eos
, ST_OMP_END_TARGET_DATA
);
890 matchs ("end target parallel do simd", gfc_match_omp_eos
,
891 ST_OMP_END_TARGET_PARALLEL_DO_SIMD
);
892 matcho ("end target parallel do", gfc_match_omp_eos
,
893 ST_OMP_END_TARGET_PARALLEL_DO
);
894 matcho ("end target parallel", gfc_match_omp_eos
,
895 ST_OMP_END_TARGET_PARALLEL
);
896 matchs ("end target simd", gfc_match_omp_eos
, ST_OMP_END_TARGET_SIMD
);
897 matchs ("end target teams distribute parallel do simd",
899 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
900 matcho ("end target teams distribute parallel do", gfc_match_omp_eos
,
901 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
902 matchs ("end target teams distribute simd", gfc_match_omp_eos
,
903 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
);
904 matcho ("end target teams distribute", gfc_match_omp_eos
,
905 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
);
906 matcho ("end target teams", gfc_match_omp_eos
, ST_OMP_END_TARGET_TEAMS
);
907 matcho ("end target", gfc_match_omp_eos
, ST_OMP_END_TARGET
);
908 matcho ("end taskgroup", gfc_match_omp_eos
, ST_OMP_END_TASKGROUP
);
909 matchs ("end taskloop simd", gfc_match_omp_eos
,
910 ST_OMP_END_TASKLOOP_SIMD
);
911 matcho ("end taskloop", gfc_match_omp_eos
, ST_OMP_END_TASKLOOP
);
912 matcho ("end task", gfc_match_omp_eos
, ST_OMP_END_TASK
);
913 matchs ("end teams distribute parallel do simd", gfc_match_omp_eos
,
914 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
915 matcho ("end teams distribute parallel do", gfc_match_omp_eos
,
916 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
);
917 matchs ("end teams distribute simd", gfc_match_omp_eos
,
918 ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
);
919 matcho ("end teams distribute", gfc_match_omp_eos
,
920 ST_OMP_END_TEAMS_DISTRIBUTE
);
921 matcho ("end teams", gfc_match_omp_eos
, ST_OMP_END_TEAMS
);
922 matcho ("end workshare", gfc_match_omp_end_nowait
,
923 ST_OMP_END_WORKSHARE
);
926 matcho ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
929 matcho ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
932 if (gfc_match ("ordered depend (") == MATCH_YES
)
934 gfc_current_locus
= old_locus
;
937 matcho ("ordered", gfc_match_omp_ordered_depend
,
938 ST_OMP_ORDERED_DEPEND
);
941 matchs ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
944 matchs ("parallel do simd", gfc_match_omp_parallel_do_simd
,
945 ST_OMP_PARALLEL_DO_SIMD
);
946 matcho ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
947 matcho ("parallel sections", gfc_match_omp_parallel_sections
,
948 ST_OMP_PARALLEL_SECTIONS
);
949 matcho ("parallel workshare", gfc_match_omp_parallel_workshare
,
950 ST_OMP_PARALLEL_WORKSHARE
);
951 matcho ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
954 matcho ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
955 matcho ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
956 matcho ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
959 matcho ("target data", gfc_match_omp_target_data
, ST_OMP_TARGET_DATA
);
960 matcho ("target enter data", gfc_match_omp_target_enter_data
,
961 ST_OMP_TARGET_ENTER_DATA
);
962 matcho ("target exit data", gfc_match_omp_target_exit_data
,
963 ST_OMP_TARGET_EXIT_DATA
);
964 matchs ("target parallel do simd", gfc_match_omp_target_parallel_do_simd
,
965 ST_OMP_TARGET_PARALLEL_DO_SIMD
);
966 matcho ("target parallel do", gfc_match_omp_target_parallel_do
,
967 ST_OMP_TARGET_PARALLEL_DO
);
968 matcho ("target parallel", gfc_match_omp_target_parallel
,
969 ST_OMP_TARGET_PARALLEL
);
970 matchs ("target simd", gfc_match_omp_target_simd
, ST_OMP_TARGET_SIMD
);
971 matchs ("target teams distribute parallel do simd",
972 gfc_match_omp_target_teams_distribute_parallel_do_simd
,
973 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
974 matcho ("target teams distribute parallel do",
975 gfc_match_omp_target_teams_distribute_parallel_do
,
976 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
977 matchs ("target teams distribute simd",
978 gfc_match_omp_target_teams_distribute_simd
,
979 ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
);
980 matcho ("target teams distribute", gfc_match_omp_target_teams_distribute
,
981 ST_OMP_TARGET_TEAMS_DISTRIBUTE
);
982 matcho ("target teams", gfc_match_omp_target_teams
, ST_OMP_TARGET_TEAMS
);
983 matcho ("target update", gfc_match_omp_target_update
,
984 ST_OMP_TARGET_UPDATE
);
985 matcho ("target", gfc_match_omp_target
, ST_OMP_TARGET
);
986 matcho ("taskgroup", gfc_match_omp_taskgroup
, ST_OMP_TASKGROUP
);
987 matchs ("taskloop simd", gfc_match_omp_taskloop_simd
,
988 ST_OMP_TASKLOOP_SIMD
);
989 matcho ("taskloop", gfc_match_omp_taskloop
, ST_OMP_TASKLOOP
);
990 matcho ("taskwait", gfc_match_omp_taskwait
, ST_OMP_TASKWAIT
);
991 matcho ("taskyield", gfc_match_omp_taskyield
, ST_OMP_TASKYIELD
);
992 matcho ("task", gfc_match_omp_task
, ST_OMP_TASK
);
993 matchs ("teams distribute parallel do simd",
994 gfc_match_omp_teams_distribute_parallel_do_simd
,
995 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
996 matcho ("teams distribute parallel do",
997 gfc_match_omp_teams_distribute_parallel_do
,
998 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
);
999 matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd
,
1000 ST_OMP_TEAMS_DISTRIBUTE_SIMD
);
1001 matcho ("teams distribute", gfc_match_omp_teams_distribute
,
1002 ST_OMP_TEAMS_DISTRIBUTE
);
1003 matcho ("teams", gfc_match_omp_teams
, ST_OMP_TEAMS
);
1004 matchdo ("threadprivate", gfc_match_omp_threadprivate
,
1005 ST_OMP_THREADPRIVATE
);
1008 matcho ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
1012 /* All else has failed, so give up. See if any of the matchers has
1013 stored an error message of some sort. Don't error out if
1014 not -fopenmp and simd_matched is false, i.e. if a directive other
1015 than one marked with match has been seen. */
1017 if (flag_openmp
|| simd_matched
)
1019 if (!gfc_error_check ())
1020 gfc_error_now ("Unclassifiable OpenMP directive at %C");
1023 reject_statement ();
1025 gfc_error_recovery ();
1032 gfc_unset_implicit_pure (NULL
);
1034 if (!flag_openmp
&& gfc_pure (NULL
))
1036 gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET "
1037 "at %C may not appear in PURE or ELEMENTAL "
1039 reject_statement ();
1040 gfc_error_recovery ();
1047 reject_statement ();
1049 gfc_buffer_error (false);
1050 gfc_current_locus
= old_locus
;
1051 return ST_GET_FCN_CHARACTERISTICS
;
1054 static gfc_statement
1055 decode_gcc_attribute (void)
1059 gfc_enforce_clean_symbol_state ();
1061 gfc_clear_error (); /* Clear any pending errors. */
1062 gfc_clear_warning (); /* Clear any pending warnings. */
1063 old_locus
= gfc_current_locus
;
1065 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
1067 /* All else has failed, so give up. See if any of the matchers has
1068 stored an error message of some sort. */
1070 if (!gfc_error_check ())
1071 gfc_error_now ("Unclassifiable GCC directive at %C");
1073 reject_statement ();
1075 gfc_error_recovery ();
1082 /* Assert next length characters to be equal to token in free form. */
1085 verify_token_free (const char* token
, int length
, bool last_was_use_stmt
)
1090 c
= gfc_next_ascii_char ();
1091 for (i
= 0; i
< length
; i
++, c
= gfc_next_ascii_char ())
1092 gcc_assert (c
== token
[i
]);
1094 gcc_assert (gfc_is_whitespace(c
));
1095 gfc_gobble_whitespace ();
1096 if (last_was_use_stmt
)
1100 /* Get the next statement in free form source. */
1102 static gfc_statement
1109 at_bol
= gfc_at_bol ();
1110 gfc_gobble_whitespace ();
1112 c
= gfc_peek_ascii_char ();
1118 /* Found a statement label? */
1119 m
= gfc_match_st_label (&gfc_statement_label
);
1121 d
= gfc_peek_ascii_char ();
1122 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
1124 gfc_match_small_literal_int (&i
, &cnt
);
1127 gfc_error_now ("Too many digits in statement label at %C");
1130 gfc_error_now ("Zero is not a valid statement label at %C");
1133 c
= gfc_next_ascii_char ();
1136 if (!gfc_is_whitespace (c
))
1137 gfc_error_now ("Non-numeric character in statement label at %C");
1143 label_locus
= gfc_current_locus
;
1145 gfc_gobble_whitespace ();
1147 if (at_bol
&& gfc_peek_ascii_char () == ';')
1149 gfc_error_now ("Semicolon at %C needs to be preceded by "
1151 gfc_next_ascii_char (); /* Eat up the semicolon. */
1155 if (gfc_match_eos () == MATCH_YES
)
1156 gfc_error_now ("Statement label without statement at %L",
1162 /* Comments have already been skipped by the time we get here,
1163 except for GCC attributes and OpenMP/OpenACC directives. */
1165 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
1166 c
= gfc_peek_ascii_char ();
1172 c
= gfc_next_ascii_char ();
1173 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
1174 gcc_assert (c
== "gcc$"[i
]);
1176 gfc_gobble_whitespace ();
1177 return decode_gcc_attribute ();
1182 /* Since both OpenMP and OpenACC directives starts with
1183 !$ character sequence, we must check all flags combinations */
1184 if ((flag_openmp
|| flag_openmp_simd
)
1187 verify_token_free ("$omp", 4, last_was_use_stmt
);
1188 return decode_omp_directive ();
1190 else if ((flag_openmp
|| flag_openmp_simd
)
1193 gfc_next_ascii_char (); /* Eat up dollar character */
1194 c
= gfc_peek_ascii_char ();
1198 verify_token_free ("omp", 3, last_was_use_stmt
);
1199 return decode_omp_directive ();
1203 verify_token_free ("acc", 3, last_was_use_stmt
);
1204 return decode_oacc_directive ();
1207 else if (flag_openacc
)
1209 verify_token_free ("$acc", 4, last_was_use_stmt
);
1210 return decode_oacc_directive ();
1216 if (at_bol
&& c
== ';')
1218 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1219 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1221 gfc_next_ascii_char (); /* Eat up the semicolon. */
1225 return decode_statement ();
1228 /* Assert next length characters to be equal to token in fixed form. */
1231 verify_token_fixed (const char *token
, int length
, bool last_was_use_stmt
)
1234 char c
= gfc_next_char_literal (NONSTRING
);
1236 for (i
= 0; i
< length
; i
++, c
= gfc_next_char_literal (NONSTRING
))
1237 gcc_assert ((char) gfc_wide_tolower (c
) == token
[i
]);
1239 if (c
!= ' ' && c
!= '0')
1241 gfc_buffer_error (false);
1242 gfc_error ("Bad continuation line at %C");
1245 if (last_was_use_stmt
)
1251 /* Get the next statement in fixed-form source. */
1253 static gfc_statement
1256 int label
, digit_flag
, i
;
1261 return decode_statement ();
1263 /* Skip past the current label field, parsing a statement label if
1264 one is there. This is a weird number parser, since the number is
1265 contained within five columns and can have any kind of embedded
1266 spaces. We also check for characters that make the rest of the
1272 for (i
= 0; i
< 5; i
++)
1274 c
= gfc_next_char_literal (NONSTRING
);
1291 label
= label
* 10 + ((unsigned char) c
- '0');
1292 label_locus
= gfc_current_locus
;
1296 /* Comments have already been skipped by the time we get
1297 here, except for GCC attributes and OpenMP directives. */
1300 c
= gfc_next_char_literal (NONSTRING
);
1302 if (TOLOWER (c
) == 'g')
1304 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
1305 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
1307 return decode_gcc_attribute ();
1311 if ((flag_openmp
|| flag_openmp_simd
)
1314 if (!verify_token_fixed ("omp", 3, last_was_use_stmt
))
1316 return decode_omp_directive ();
1318 else if ((flag_openmp
|| flag_openmp_simd
)
1321 c
= gfc_next_char_literal(NONSTRING
);
1322 if (c
== 'o' || c
== 'O')
1324 if (!verify_token_fixed ("mp", 2, last_was_use_stmt
))
1326 return decode_omp_directive ();
1328 else if (c
== 'a' || c
== 'A')
1330 if (!verify_token_fixed ("cc", 2, last_was_use_stmt
))
1332 return decode_oacc_directive ();
1335 else if (flag_openacc
)
1337 if (!verify_token_fixed ("acc", 3, last_was_use_stmt
))
1339 return decode_oacc_directive ();
1344 /* Comments have already been skipped by the time we get
1345 here so don't bother checking for them. */
1348 gfc_buffer_error (false);
1349 gfc_error ("Non-numeric character in statement label at %C");
1357 gfc_warning_now (0, "Zero is not a valid statement label at %C");
1360 /* We've found a valid statement label. */
1361 gfc_statement_label
= gfc_get_st_label (label
);
1365 /* Since this line starts a statement, it cannot be a continuation
1366 of a previous statement. If we see something here besides a
1367 space or zero, it must be a bad continuation line. */
1369 c
= gfc_next_char_literal (NONSTRING
);
1373 if (c
!= ' ' && c
!= '0')
1375 gfc_buffer_error (false);
1376 gfc_error ("Bad continuation line at %C");
1380 /* Now that we've taken care of the statement label columns, we have
1381 to make sure that the first nonblank character is not a '!'. If
1382 it is, the rest of the line is a comment. */
1386 loc
= gfc_current_locus
;
1387 c
= gfc_next_char_literal (NONSTRING
);
1389 while (gfc_is_whitespace (c
));
1393 gfc_current_locus
= loc
;
1398 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1399 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1400 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1405 if (gfc_match_eos () == MATCH_YES
)
1408 /* At this point, we've got a nonblank statement to parse. */
1409 return decode_statement ();
1413 gfc_error_now ("Statement label without statement at %L", &label_locus
);
1415 gfc_current_locus
.lb
->truncated
= 0;
1416 gfc_advance_line ();
1421 /* Return the next non-ST_NONE statement to the caller. We also worry
1422 about including files and the ends of include files at this stage. */
1424 static gfc_statement
1425 next_statement (void)
1430 gfc_enforce_clean_symbol_state ();
1432 gfc_new_block
= NULL
;
1434 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1435 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
1438 gfc_statement_label
= NULL
;
1439 gfc_buffer_error (true);
1442 gfc_advance_line ();
1444 gfc_skip_comments ();
1452 if (gfc_define_undef_line ())
1455 old_locus
= gfc_current_locus
;
1457 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1463 gfc_buffer_error (false);
1465 if (st
== ST_GET_FCN_CHARACTERISTICS
)
1467 if (gfc_statement_label
!= NULL
)
1469 gfc_free_st_label (gfc_statement_label
);
1470 gfc_statement_label
= NULL
;
1472 gfc_current_locus
= old_locus
;
1476 check_statement_label (st
);
1482 /****************************** Parser ***********************************/
1484 /* The parser subroutines are of type 'try' that fail if the file ends
1487 /* Macros that expand to case-labels for various classes of
1488 statements. Start with executable statements that directly do
1491 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1492 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1493 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1494 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1495 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1496 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1497 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1498 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1499 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1500 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
1501 case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
1502 case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: \
1503 case ST_ERROR_STOP: case ST_SYNC_ALL: \
1504 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1505 case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
1506 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1507 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1509 /* Statements that mark other executable statements. */
1511 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1512 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1513 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1514 case ST_OMP_PARALLEL: \
1515 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1516 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
1517 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1518 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1519 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1520 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1521 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1522 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1523 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1524 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1525 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1526 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1527 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1528 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1529 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1530 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1531 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \
1532 case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \
1533 case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
1535 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1536 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
1537 case ST_OACC_KERNELS_LOOP: case ST_OACC_ATOMIC
1539 /* Declaration statements */
1541 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1542 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1543 case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE: case ST_OACC_ROUTINE: \
1544 case ST_OACC_DECLARE
1546 /* OpenMP declaration statements. */
1548 #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
1549 case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION
1551 /* Block end statements. Errors associated with interchanging these
1552 are detected in gfc_match_end(). */
1554 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1555 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1556 case ST_END_BLOCK: case ST_END_ASSOCIATE
1559 /* Push a new state onto the stack. */
1562 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1564 p
->state
= new_state
;
1565 p
->previous
= gfc_state_stack
;
1567 p
->head
= p
->tail
= NULL
;
1568 p
->do_variable
= NULL
;
1569 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1570 p
->ext
.oacc_declare_clauses
= NULL
;
1572 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1573 construct statement was accepted right before pushing the state. Thus,
1574 the construct's gfc_code is available as tail of the parent state. */
1575 gcc_assert (gfc_state_stack
);
1576 p
->construct
= gfc_state_stack
->tail
;
1578 gfc_state_stack
= p
;
1582 /* Pop the current state. */
1586 gfc_state_stack
= gfc_state_stack
->previous
;
1590 /* Try to find the given state in the state stack. */
1593 gfc_find_state (gfc_compile_state state
)
1597 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1598 if (p
->state
== state
)
1601 return (p
== NULL
) ? false : true;
1605 /* Starts a new level in the statement list. */
1608 new_level (gfc_code
*q
)
1612 p
= q
->block
= gfc_get_code (EXEC_NOP
);
1614 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1620 /* Add the current new_st code structure and adds it to the current
1621 program unit. As a side-effect, it zeroes the new_st. */
1624 add_statement (void)
1628 p
= XCNEW (gfc_code
);
1631 p
->loc
= gfc_current_locus
;
1633 if (gfc_state_stack
->head
== NULL
)
1634 gfc_state_stack
->head
= p
;
1636 gfc_state_stack
->tail
->next
= p
;
1638 while (p
->next
!= NULL
)
1641 gfc_state_stack
->tail
= p
;
1643 gfc_clear_new_st ();
1649 /* Frees everything associated with the current statement. */
1652 undo_new_statement (void)
1654 gfc_free_statements (new_st
.block
);
1655 gfc_free_statements (new_st
.next
);
1656 gfc_free_statement (&new_st
);
1657 gfc_clear_new_st ();
1661 /* If the current statement has a statement label, make sure that it
1662 is allowed to, or should have one. */
1665 check_statement_label (gfc_statement st
)
1669 if (gfc_statement_label
== NULL
)
1671 if (st
== ST_FORMAT
)
1672 gfc_error ("FORMAT statement at %L does not have a statement label",
1679 case ST_END_PROGRAM
:
1680 case ST_END_FUNCTION
:
1681 case ST_END_SUBROUTINE
:
1685 case ST_END_CRITICAL
:
1687 case ST_END_ASSOCIATE
:
1690 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
1691 type
= ST_LABEL_DO_TARGET
;
1693 type
= ST_LABEL_TARGET
;
1697 type
= ST_LABEL_FORMAT
;
1700 /* Statement labels are not restricted from appearing on a
1701 particular line. However, there are plenty of situations
1702 where the resulting label can't be referenced. */
1705 type
= ST_LABEL_BAD_TARGET
;
1709 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1711 new_st
.here
= gfc_statement_label
;
1715 /* Figures out what the enclosing program unit is. This will be a
1716 function, subroutine, program, block data or module. */
1719 gfc_enclosing_unit (gfc_compile_state
* result
)
1723 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1724 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1725 || p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
1726 || p
->state
== COMP_BLOCK_DATA
|| p
->state
== COMP_PROGRAM
)
1735 *result
= COMP_PROGRAM
;
1740 /* Translate a statement enum to a string. */
1743 gfc_ascii_statement (gfc_statement st
)
1749 case ST_ARITHMETIC_IF
:
1750 p
= _("arithmetic IF");
1759 p
= _("attribute declaration");
1795 p
= _("data declaration");
1809 case ST_STRUCTURE_DECL
:
1812 case ST_DERIVED_DECL
:
1813 p
= _("derived type declaration");
1836 case ST_END_ASSOCIATE
:
1837 p
= "END ASSOCIATE";
1842 case ST_END_BLOCK_DATA
:
1843 p
= "END BLOCK DATA";
1845 case ST_END_CRITICAL
:
1857 case ST_END_FUNCTION
:
1863 case ST_END_INTERFACE
:
1864 p
= "END INTERFACE";
1869 case ST_END_SUBMODULE
:
1870 p
= "END SUBMODULE";
1872 case ST_END_PROGRAM
:
1878 case ST_END_SUBROUTINE
:
1879 p
= "END SUBROUTINE";
1884 case ST_END_STRUCTURE
:
1885 p
= "END STRUCTURE";
1899 case ST_EQUIVALENCE
:
1911 case ST_FORALL_BLOCK
: /* Fall through */
1933 case ST_IMPLICIT_NONE
:
1934 p
= "IMPLICIT NONE";
1936 case ST_IMPLIED_ENDDO
:
1937 p
= _("implied END DO");
1969 case ST_MODULE_PROC
:
1970 p
= "MODULE PROCEDURE";
2002 case ST_SYNC_IMAGES
:
2005 case ST_SYNC_MEMORY
:
2020 case ST_WHERE_BLOCK
: /* Fall through */
2031 p
= _("assignment");
2033 case ST_POINTER_ASSIGNMENT
:
2034 p
= _("pointer assignment");
2036 case ST_SELECT_CASE
:
2039 case ST_SELECT_TYPE
:
2054 case ST_STATEMENT_FUNCTION
:
2055 p
= "STATEMENT FUNCTION";
2057 case ST_LABEL_ASSIGNMENT
:
2058 p
= "LABEL ASSIGNMENT";
2061 p
= "ENUM DEFINITION";
2064 p
= "ENUMERATOR DEFINITION";
2069 case ST_OACC_PARALLEL_LOOP
:
2070 p
= "!$ACC PARALLEL LOOP";
2072 case ST_OACC_END_PARALLEL_LOOP
:
2073 p
= "!$ACC END PARALLEL LOOP";
2075 case ST_OACC_PARALLEL
:
2076 p
= "!$ACC PARALLEL";
2078 case ST_OACC_END_PARALLEL
:
2079 p
= "!$ACC END PARALLEL";
2081 case ST_OACC_KERNELS
:
2082 p
= "!$ACC KERNELS";
2084 case ST_OACC_END_KERNELS
:
2085 p
= "!$ACC END KERNELS";
2087 case ST_OACC_KERNELS_LOOP
:
2088 p
= "!$ACC KERNELS LOOP";
2090 case ST_OACC_END_KERNELS_LOOP
:
2091 p
= "!$ACC END KERNELS LOOP";
2096 case ST_OACC_END_DATA
:
2097 p
= "!$ACC END DATA";
2099 case ST_OACC_HOST_DATA
:
2100 p
= "!$ACC HOST_DATA";
2102 case ST_OACC_END_HOST_DATA
:
2103 p
= "!$ACC END HOST_DATA";
2108 case ST_OACC_END_LOOP
:
2109 p
= "!$ACC END LOOP";
2111 case ST_OACC_DECLARE
:
2112 p
= "!$ACC DECLARE";
2114 case ST_OACC_UPDATE
:
2123 case ST_OACC_ENTER_DATA
:
2124 p
= "!$ACC ENTER DATA";
2126 case ST_OACC_EXIT_DATA
:
2127 p
= "!$ACC EXIT DATA";
2129 case ST_OACC_ROUTINE
:
2130 p
= "!$ACC ROUTINE";
2132 case ST_OACC_ATOMIC
:
2135 case ST_OACC_END_ATOMIC
:
2136 p
= "!$ACC END ATOMIC";
2141 case ST_OMP_BARRIER
:
2142 p
= "!$OMP BARRIER";
2147 case ST_OMP_CANCELLATION_POINT
:
2148 p
= "!$OMP CANCELLATION POINT";
2150 case ST_OMP_CRITICAL
:
2151 p
= "!$OMP CRITICAL";
2153 case ST_OMP_DECLARE_REDUCTION
:
2154 p
= "!$OMP DECLARE REDUCTION";
2156 case ST_OMP_DECLARE_SIMD
:
2157 p
= "!$OMP DECLARE SIMD";
2159 case ST_OMP_DECLARE_TARGET
:
2160 p
= "!$OMP DECLARE TARGET";
2162 case ST_OMP_DISTRIBUTE
:
2163 p
= "!$OMP DISTRIBUTE";
2165 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
2166 p
= "!$OMP DISTRIBUTE PARALLEL DO";
2168 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2169 p
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
2171 case ST_OMP_DISTRIBUTE_SIMD
:
2172 p
= "!$OMP DISTRIBUTE SIMD";
2177 case ST_OMP_DO_SIMD
:
2178 p
= "!$OMP DO SIMD";
2180 case ST_OMP_END_ATOMIC
:
2181 p
= "!$OMP END ATOMIC";
2183 case ST_OMP_END_CRITICAL
:
2184 p
= "!$OMP END CRITICAL";
2186 case ST_OMP_END_DISTRIBUTE
:
2187 p
= "!$OMP END DISTRIBUTE";
2189 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO
:
2190 p
= "!$OMP END DISTRIBUTE PARALLEL DO";
2192 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
:
2193 p
= "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
2195 case ST_OMP_END_DISTRIBUTE_SIMD
:
2196 p
= "!$OMP END DISTRIBUTE SIMD";
2201 case ST_OMP_END_DO_SIMD
:
2202 p
= "!$OMP END DO SIMD";
2204 case ST_OMP_END_SIMD
:
2205 p
= "!$OMP END SIMD";
2207 case ST_OMP_END_MASTER
:
2208 p
= "!$OMP END MASTER";
2210 case ST_OMP_END_ORDERED
:
2211 p
= "!$OMP END ORDERED";
2213 case ST_OMP_END_PARALLEL
:
2214 p
= "!$OMP END PARALLEL";
2216 case ST_OMP_END_PARALLEL_DO
:
2217 p
= "!$OMP END PARALLEL DO";
2219 case ST_OMP_END_PARALLEL_DO_SIMD
:
2220 p
= "!$OMP END PARALLEL DO SIMD";
2222 case ST_OMP_END_PARALLEL_SECTIONS
:
2223 p
= "!$OMP END PARALLEL SECTIONS";
2225 case ST_OMP_END_PARALLEL_WORKSHARE
:
2226 p
= "!$OMP END PARALLEL WORKSHARE";
2228 case ST_OMP_END_SECTIONS
:
2229 p
= "!$OMP END SECTIONS";
2231 case ST_OMP_END_SINGLE
:
2232 p
= "!$OMP END SINGLE";
2234 case ST_OMP_END_TASK
:
2235 p
= "!$OMP END TASK";
2237 case ST_OMP_END_TARGET
:
2238 p
= "!$OMP END TARGET";
2240 case ST_OMP_END_TARGET_DATA
:
2241 p
= "!$OMP END TARGET DATA";
2243 case ST_OMP_END_TARGET_PARALLEL
:
2244 p
= "!$OMP END TARGET PARALLEL";
2246 case ST_OMP_END_TARGET_PARALLEL_DO
:
2247 p
= "!$OMP END TARGET PARALLEL DO";
2249 case ST_OMP_END_TARGET_PARALLEL_DO_SIMD
:
2250 p
= "!$OMP END TARGET PARALLEL DO SIMD";
2252 case ST_OMP_END_TARGET_SIMD
:
2253 p
= "!$OMP END TARGET SIMD";
2255 case ST_OMP_END_TARGET_TEAMS
:
2256 p
= "!$OMP END TARGET TEAMS";
2258 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
:
2259 p
= "!$OMP END TARGET TEAMS DISTRIBUTE";
2261 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2262 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2264 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2265 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2267 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2268 p
= "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2270 case ST_OMP_END_TASKGROUP
:
2271 p
= "!$OMP END TASKGROUP";
2273 case ST_OMP_END_TASKLOOP
:
2274 p
= "!$OMP END TASKLOOP";
2276 case ST_OMP_END_TASKLOOP_SIMD
:
2277 p
= "!$OMP END TASKLOOP SIMD";
2279 case ST_OMP_END_TEAMS
:
2280 p
= "!$OMP END TEAMS";
2282 case ST_OMP_END_TEAMS_DISTRIBUTE
:
2283 p
= "!$OMP END TEAMS DISTRIBUTE";
2285 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2286 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2288 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2289 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2291 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
:
2292 p
= "!$OMP END TEAMS DISTRIBUTE SIMD";
2294 case ST_OMP_END_WORKSHARE
:
2295 p
= "!$OMP END WORKSHARE";
2303 case ST_OMP_ORDERED
:
2304 case ST_OMP_ORDERED_DEPEND
:
2305 p
= "!$OMP ORDERED";
2307 case ST_OMP_PARALLEL
:
2308 p
= "!$OMP PARALLEL";
2310 case ST_OMP_PARALLEL_DO
:
2311 p
= "!$OMP PARALLEL DO";
2313 case ST_OMP_PARALLEL_DO_SIMD
:
2314 p
= "!$OMP PARALLEL DO SIMD";
2316 case ST_OMP_PARALLEL_SECTIONS
:
2317 p
= "!$OMP PARALLEL SECTIONS";
2319 case ST_OMP_PARALLEL_WORKSHARE
:
2320 p
= "!$OMP PARALLEL WORKSHARE";
2322 case ST_OMP_SECTIONS
:
2323 p
= "!$OMP SECTIONS";
2325 case ST_OMP_SECTION
:
2326 p
= "!$OMP SECTION";
2337 case ST_OMP_TARGET_DATA
:
2338 p
= "!$OMP TARGET DATA";
2340 case ST_OMP_TARGET_ENTER_DATA
:
2341 p
= "!$OMP TARGET ENTER DATA";
2343 case ST_OMP_TARGET_EXIT_DATA
:
2344 p
= "!$OMP TARGET EXIT DATA";
2346 case ST_OMP_TARGET_PARALLEL
:
2347 p
= "!$OMP TARGET PARALLEL";
2349 case ST_OMP_TARGET_PARALLEL_DO
:
2350 p
= "!$OMP TARGET PARALLEL DO";
2352 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
2353 p
= "!$OMP TARGET PARALLEL DO SIMD";
2355 case ST_OMP_TARGET_SIMD
:
2356 p
= "!$OMP TARGET SIMD";
2358 case ST_OMP_TARGET_TEAMS
:
2359 p
= "!$OMP TARGET TEAMS";
2361 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
2362 p
= "!$OMP TARGET TEAMS DISTRIBUTE";
2364 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2365 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2367 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2368 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2370 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2371 p
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2373 case ST_OMP_TARGET_UPDATE
:
2374 p
= "!$OMP TARGET UPDATE";
2379 case ST_OMP_TASKGROUP
:
2380 p
= "!$OMP TASKGROUP";
2382 case ST_OMP_TASKLOOP
:
2383 p
= "!$OMP TASKLOOP";
2385 case ST_OMP_TASKLOOP_SIMD
:
2386 p
= "!$OMP TASKLOOP SIMD";
2388 case ST_OMP_TASKWAIT
:
2389 p
= "!$OMP TASKWAIT";
2391 case ST_OMP_TASKYIELD
:
2392 p
= "!$OMP TASKYIELD";
2397 case ST_OMP_TEAMS_DISTRIBUTE
:
2398 p
= "!$OMP TEAMS DISTRIBUTE";
2400 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2401 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2403 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2404 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2406 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
2407 p
= "!$OMP TEAMS DISTRIBUTE SIMD";
2409 case ST_OMP_THREADPRIVATE
:
2410 p
= "!$OMP THREADPRIVATE";
2412 case ST_OMP_WORKSHARE
:
2413 p
= "!$OMP WORKSHARE";
2416 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2423 /* Create a symbol for the main program and assign it to ns->proc_name. */
2426 main_program_symbol (gfc_namespace
*ns
, const char *name
)
2428 gfc_symbol
*main_program
;
2429 symbol_attribute attr
;
2431 gfc_get_symbol (name
, ns
, &main_program
);
2432 gfc_clear_attr (&attr
);
2433 attr
.flavor
= FL_PROGRAM
;
2434 attr
.proc
= PROC_UNKNOWN
;
2435 attr
.subroutine
= 1;
2436 attr
.access
= ACCESS_PUBLIC
;
2437 attr
.is_main_program
= 1;
2438 main_program
->attr
= attr
;
2439 main_program
->declared_at
= gfc_current_locus
;
2440 ns
->proc_name
= main_program
;
2441 gfc_commit_symbols ();
2445 /* Do whatever is necessary to accept the last statement. */
2448 accept_statement (gfc_statement st
)
2452 case ST_IMPLICIT_NONE
:
2460 gfc_current_ns
->proc_name
= gfc_new_block
;
2463 /* If the statement is the end of a block, lay down a special code
2464 that allows a branch to the end of the block from within the
2465 construct. IF and SELECT are treated differently from DO
2466 (where EXEC_NOP is added inside the loop) for two
2468 1. END DO has a meaning in the sense that after a GOTO to
2469 it, the loop counter must be increased.
2470 2. IF blocks and SELECT blocks can consist of multiple
2471 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
2472 Putting the label before the END IF would make the jump
2473 from, say, the ELSE IF block to the END IF illegal. */
2477 case ST_END_CRITICAL
:
2478 if (gfc_statement_label
!= NULL
)
2480 new_st
.op
= EXEC_END_NESTED_BLOCK
;
2485 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
2486 one parallel block. Thus, we add the special code to the nested block
2487 itself, instead of the parent one. */
2489 case ST_END_ASSOCIATE
:
2490 if (gfc_statement_label
!= NULL
)
2492 new_st
.op
= EXEC_END_BLOCK
;
2497 /* The end-of-program unit statements do not get the special
2498 marker and require a statement of some sort if they are a
2501 case ST_END_PROGRAM
:
2502 case ST_END_FUNCTION
:
2503 case ST_END_SUBROUTINE
:
2504 if (gfc_statement_label
!= NULL
)
2506 new_st
.op
= EXEC_RETURN
;
2511 new_st
.op
= EXEC_END_PROCEDURE
;
2527 gfc_commit_symbols ();
2528 gfc_warning_check ();
2529 gfc_clear_new_st ();
2533 /* Undo anything tentative that has been built for the current statement,
2534 except if a gfc_charlen structure has been added to current namespace's
2535 list of gfc_charlen structure. */
2538 reject_statement (void)
2540 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
2541 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
2543 gfc_reject_data (gfc_current_ns
);
2545 gfc_new_block
= NULL
;
2546 gfc_undo_symbols ();
2547 gfc_clear_warning ();
2548 undo_new_statement ();
2552 /* Generic complaint about an out of order statement. We also do
2553 whatever is necessary to clean up. */
2556 unexpected_statement (gfc_statement st
)
2558 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
2560 reject_statement ();
2564 /* Given the next statement seen by the matcher, make sure that it is
2565 in proper order with the last. This subroutine is initialized by
2566 calling it with an argument of ST_NONE. If there is a problem, we
2567 issue an error and return false. Otherwise we return true.
2569 Individual parsers need to verify that the statements seen are
2570 valid before calling here, i.e., ENTRY statements are not allowed in
2571 INTERFACE blocks. The following diagram is taken from the standard:
2573 +---------------------------------------+
2574 | program subroutine function module |
2575 +---------------------------------------+
2577 +---------------------------------------+
2579 +---------------------------------------+
2581 | +-----------+------------------+
2582 | | parameter | implicit |
2583 | +-----------+------------------+
2584 | format | | derived type |
2585 | entry | parameter | interface |
2586 | | data | specification |
2587 | | | statement func |
2588 | +-----------+------------------+
2589 | | data | executable |
2590 +--------+-----------+------------------+
2592 +---------------------------------------+
2593 | internal module/subprogram |
2594 +---------------------------------------+
2596 +---------------------------------------+
2605 ORDER_IMPLICIT_NONE
,
2613 enum state_order state
;
2614 gfc_statement last_statement
;
2620 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
2626 p
->state
= ORDER_START
;
2630 if (p
->state
> ORDER_USE
)
2632 p
->state
= ORDER_USE
;
2636 if (p
->state
> ORDER_IMPORT
)
2638 p
->state
= ORDER_IMPORT
;
2641 case ST_IMPLICIT_NONE
:
2642 if (p
->state
> ORDER_IMPLICIT
)
2645 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2646 statement disqualifies a USE but not an IMPLICIT NONE.
2647 Duplicate IMPLICIT NONEs are caught when the implicit types
2650 p
->state
= ORDER_IMPLICIT_NONE
;
2654 if (p
->state
> ORDER_IMPLICIT
)
2656 p
->state
= ORDER_IMPLICIT
;
2661 if (p
->state
< ORDER_IMPLICIT_NONE
)
2662 p
->state
= ORDER_IMPLICIT_NONE
;
2666 if (p
->state
>= ORDER_EXEC
)
2668 if (p
->state
< ORDER_IMPLICIT
)
2669 p
->state
= ORDER_IMPLICIT
;
2673 if (p
->state
< ORDER_SPEC
)
2674 p
->state
= ORDER_SPEC
;
2679 case ST_STRUCTURE_DECL
:
2680 case ST_DERIVED_DECL
:
2682 if (p
->state
>= ORDER_EXEC
)
2684 if (p
->state
< ORDER_SPEC
)
2685 p
->state
= ORDER_SPEC
;
2689 /* The OpenMP directives have to be somewhere in the specification
2690 part, but there are no further requirements on their ordering.
2691 Thus don't adjust p->state, just ignore them. */
2692 if (p
->state
>= ORDER_EXEC
)
2698 if (p
->state
< ORDER_EXEC
)
2699 p
->state
= ORDER_EXEC
;
2706 /* All is well, record the statement in case we need it next time. */
2707 p
->where
= gfc_current_locus
;
2708 p
->last_statement
= st
;
2713 gfc_error ("%s statement at %C cannot follow %s statement at %L",
2714 gfc_ascii_statement (st
),
2715 gfc_ascii_statement (p
->last_statement
), &p
->where
);
2721 /* Handle an unexpected end of file. This is a show-stopper... */
2723 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
2726 unexpected_eof (void)
2730 gfc_error ("Unexpected end of file in %qs", gfc_source_file
);
2732 /* Memory cleanup. Move to "second to last". */
2733 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
2736 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
2739 longjmp (eof_buf
, 1);
2743 /* Parse the CONTAINS section of a derived type definition. */
2745 gfc_access gfc_typebound_default_access
;
2748 parse_derived_contains (void)
2751 bool seen_private
= false;
2752 bool seen_comps
= false;
2753 bool error_flag
= false;
2756 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2757 gcc_assert (gfc_current_block ());
2759 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
2761 if (gfc_current_block ()->attr
.sequence
)
2762 gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
2763 " section at %C", gfc_current_block ()->name
);
2764 if (gfc_current_block ()->attr
.is_bind_c
)
2765 gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
2766 " section at %C", gfc_current_block ()->name
);
2768 accept_statement (ST_CONTAINS
);
2769 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
2771 gfc_typebound_default_access
= ACCESS_PUBLIC
;
2777 st
= next_statement ();
2785 gfc_error ("Components in TYPE at %C must precede CONTAINS");
2789 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
2792 accept_statement (ST_PROCEDURE
);
2797 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
2800 accept_statement (ST_GENERIC
);
2805 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
2809 accept_statement (ST_FINAL
);
2817 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
2818 "at %C with empty CONTAINS section")))
2821 /* ST_END_TYPE is accepted by parse_derived after return. */
2825 if (!gfc_find_state (COMP_MODULE
))
2827 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2834 gfc_error ("PRIVATE statement at %C must precede procedure"
2841 gfc_error ("Duplicate PRIVATE statement at %C");
2845 accept_statement (ST_PRIVATE
);
2846 gfc_typebound_default_access
= ACCESS_PRIVATE
;
2847 seen_private
= true;
2851 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2855 gfc_error ("Already inside a CONTAINS block at %C");
2859 unexpected_statement (st
);
2867 reject_statement ();
2871 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2877 /* Set attributes for the parent symbol based on the attributes of a component
2878 and raise errors if conflicting attributes are found for the component. */
2881 check_component (gfc_symbol
*sym
, gfc_component
*c
, gfc_component
**lockp
,
2882 gfc_component
**eventp
)
2884 bool coarray
, lock_type
, event_type
, allocatable
, pointer
;
2885 coarray
= lock_type
= event_type
= allocatable
= pointer
= false;
2886 gfc_component
*lock_comp
= NULL
, *event_comp
= NULL
;
2888 if (lockp
) lock_comp
= *lockp
;
2889 if (eventp
) event_comp
= *eventp
;
2891 /* Look for allocatable components. */
2892 if (c
->attr
.allocatable
2893 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2894 && CLASS_DATA (c
)->attr
.allocatable
)
2895 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
2896 && c
->ts
.u
.derived
->attr
.alloc_comp
))
2899 sym
->attr
.alloc_comp
= 1;
2902 /* Look for pointer components. */
2904 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2905 && CLASS_DATA (c
)->attr
.class_pointer
)
2906 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
2909 sym
->attr
.pointer_comp
= 1;
2912 /* Look for procedure pointer components. */
2913 if (c
->attr
.proc_pointer
2914 || (c
->ts
.type
== BT_DERIVED
2915 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
2916 sym
->attr
.proc_pointer_comp
= 1;
2918 /* Looking for coarray components. */
2919 if (c
->attr
.codimension
2920 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2921 && CLASS_DATA (c
)->attr
.codimension
))
2924 sym
->attr
.coarray_comp
= 1;
2927 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
2928 && !c
->attr
.pointer
)
2931 sym
->attr
.coarray_comp
= 1;
2934 /* Looking for lock_type components. */
2935 if ((c
->ts
.type
== BT_DERIVED
2936 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2937 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2938 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2939 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2940 == INTMOD_ISO_FORTRAN_ENV
2941 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2942 == ISOFORTRAN_LOCK_TYPE
)
2943 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
2944 && !allocatable
&& !pointer
))
2948 sym
->attr
.lock_comp
= 1;
2951 /* Looking for event_type components. */
2952 if ((c
->ts
.type
== BT_DERIVED
2953 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2954 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2955 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2956 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2957 == INTMOD_ISO_FORTRAN_ENV
2958 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2959 == ISOFORTRAN_EVENT_TYPE
)
2960 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.event_comp
2961 && !allocatable
&& !pointer
))
2965 sym
->attr
.event_comp
= 1;
2968 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2969 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2970 unless there are nondirect [allocatable or pointer] components
2971 involved (cf. 1.3.33.1 and 1.3.33.3). */
2973 if (pointer
&& !coarray
&& lock_type
)
2974 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2975 "codimension or be a subcomponent of a coarray, "
2976 "which is not possible as the component has the "
2977 "pointer attribute", c
->name
, &c
->loc
);
2978 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
2979 && c
->ts
.u
.derived
->attr
.lock_comp
)
2980 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2981 "of type LOCK_TYPE, which must have a codimension or be a "
2982 "subcomponent of a coarray", c
->name
, &c
->loc
);
2984 if (lock_type
&& allocatable
&& !coarray
)
2985 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
2986 "a codimension", c
->name
, &c
->loc
);
2987 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
2988 && c
->ts
.u
.derived
->attr
.lock_comp
)
2989 gfc_error ("Allocatable component %s at %L must have a codimension as "
2990 "it has a noncoarray subcomponent of type LOCK_TYPE",
2993 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
2994 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2995 "subcomponent of type LOCK_TYPE must have a codimension or "
2996 "be a subcomponent of a coarray. (Variables of type %s may "
2997 "not have a codimension as already a coarray "
2998 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
3000 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
3001 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3002 "subcomponent of type LOCK_TYPE must have a codimension or "
3003 "be a subcomponent of a coarray. (Variables of type %s may "
3004 "not have a codimension as %s at %L has a codimension or a "
3005 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
3006 sym
->name
, c
->name
, &c
->loc
);
3008 /* Similarly for EVENT TYPE. */
3010 if (pointer
&& !coarray
&& event_type
)
3011 gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
3012 "codimension or be a subcomponent of a coarray, "
3013 "which is not possible as the component has the "
3014 "pointer attribute", c
->name
, &c
->loc
);
3015 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
3016 && c
->ts
.u
.derived
->attr
.event_comp
)
3017 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3018 "of type EVENT_TYPE, which must have a codimension or be a "
3019 "subcomponent of a coarray", c
->name
, &c
->loc
);
3021 if (event_type
&& allocatable
&& !coarray
)
3022 gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
3023 "a codimension", c
->name
, &c
->loc
);
3024 else if (event_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
3025 && c
->ts
.u
.derived
->attr
.event_comp
)
3026 gfc_error ("Allocatable component %s at %L must have a codimension as "
3027 "it has a noncoarray subcomponent of type EVENT_TYPE",
3030 if (sym
->attr
.coarray_comp
&& !coarray
&& event_type
)
3031 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3032 "subcomponent of type EVENT_TYPE must have a codimension or "
3033 "be a subcomponent of a coarray. (Variables of type %s may "
3034 "not have a codimension as already a coarray "
3035 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
3037 if (sym
->attr
.event_comp
&& coarray
&& !event_type
)
3038 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3039 "subcomponent of type EVENT_TYPE must have a codimension or "
3040 "be a subcomponent of a coarray. (Variables of type %s may "
3041 "not have a codimension as %s at %L has a codimension or a "
3042 "coarray subcomponent)", event_comp
->name
, &event_comp
->loc
,
3043 sym
->name
, c
->name
, &c
->loc
);
3045 /* Look for private components. */
3046 if (sym
->component_access
== ACCESS_PRIVATE
3047 || c
->attr
.access
== ACCESS_PRIVATE
3048 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
3049 sym
->attr
.private_comp
= 1;
3051 if (lockp
) *lockp
= lock_comp
;
3052 if (eventp
) *eventp
= event_comp
;
3056 static void parse_struct_map (gfc_statement
);
3058 /* Parse a union component definition within a structure definition. */
3066 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3069 accept_statement(ST_UNION
);
3070 push_state (&s
, COMP_UNION
, gfc_new_block
);
3077 st
= next_statement ();
3078 /* Only MAP declarations valid within a union. */
3085 accept_statement (ST_MAP
);
3086 parse_struct_map (ST_MAP
);
3087 /* Add a component to the union for each map. */
3088 if (!gfc_add_component (un
, gfc_new_block
->name
, &c
))
3090 gfc_internal_error ("failed to create map component '%s'",
3091 gfc_new_block
->name
);
3092 reject_statement ();
3095 c
->ts
.type
= BT_DERIVED
;
3096 c
->ts
.u
.derived
= gfc_new_block
;
3097 /* Normally components get their initialization expressions when they
3098 are created in decl.c (build_struct) so we can look through the
3099 flat component list for initializers during resolution. Unions and
3100 maps create components along with their type definitions so we
3101 have to generate initializers here. */
3102 c
->initializer
= gfc_default_initializer (&c
->ts
);
3107 accept_statement (ST_END_UNION
);
3111 unexpected_statement (st
);
3116 for (c
= un
->components
; c
; c
= c
->next
)
3117 check_component (un
, c
, &lock_comp
, &event_comp
);
3119 /* Add the union as a component in its parent structure. */
3121 if (!gfc_add_component (gfc_current_block (), un
->name
, &c
))
3123 gfc_internal_error ("failed to create union component '%s'", un
->name
);
3124 reject_statement ();
3127 c
->ts
.type
= BT_UNION
;
3128 c
->ts
.u
.derived
= un
;
3129 c
->initializer
= gfc_default_initializer (&c
->ts
);
3131 un
->attr
.zero_comp
= un
->components
== NULL
;
3135 /* Parse a STRUCTURE or MAP. */
3138 parse_struct_map (gfc_statement block
)
3144 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3145 gfc_compile_state comp
;
3148 if (block
== ST_STRUCTURE_DECL
)
3150 comp
= COMP_STRUCTURE
;
3151 ends
= ST_END_STRUCTURE
;
3155 gcc_assert (block
== ST_MAP
);
3160 accept_statement(block
);
3161 push_state (&s
, comp
, gfc_new_block
);
3163 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3166 while (compiling_type
)
3168 st
= next_statement ();
3174 /* Nested structure declarations will be captured as ST_DATA_DECL. */
3175 case ST_STRUCTURE_DECL
:
3176 /* Let a more specific error make it to decode_statement(). */
3177 if (gfc_error_check () == 0)
3178 gfc_error ("Syntax error in nested structure declaration at %C");
3179 reject_statement ();
3180 /* Skip the rest of this statement. */
3181 gfc_error_recovery ();
3185 accept_statement (ST_UNION
);
3190 /* The data declaration was a nested/ad-hoc STRUCTURE field. */
3191 accept_statement (ST_DATA_DECL
);
3192 if (gfc_new_block
&& gfc_new_block
!= gfc_current_block ()
3193 && gfc_new_block
->attr
.flavor
== FL_STRUCT
)
3194 parse_struct_map (ST_STRUCTURE_DECL
);
3197 case ST_END_STRUCTURE
:
3201 accept_statement (st
);
3205 unexpected_statement (st
);
3209 unexpected_statement (st
);
3214 /* Validate each component. */
3215 sym
= gfc_current_block ();
3216 for (c
= sym
->components
; c
; c
= c
->next
)
3217 check_component (sym
, c
, &lock_comp
, &event_comp
);
3219 sym
->attr
.zero_comp
= (sym
->components
== NULL
);
3221 /* Allow parse_union to find this structure to add to its list of maps. */
3222 if (block
== ST_MAP
)
3223 gfc_new_block
= gfc_current_block ();
3229 /* Parse a derived type. */
3232 parse_derived (void)
3234 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
3238 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3240 accept_statement (ST_DERIVED_DECL
);
3241 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
3243 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3250 while (compiling_type
)
3252 st
= next_statement ();
3260 accept_statement (st
);
3265 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
3272 if (!seen_component
)
3273 gfc_notify_std (GFC_STD_F2003
, "Derived type "
3274 "definition at %C without components");
3276 accept_statement (ST_END_TYPE
);
3280 if (!gfc_find_state (COMP_MODULE
))
3282 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3289 gfc_error ("PRIVATE statement at %C must precede "
3290 "structure components");
3295 gfc_error ("Duplicate PRIVATE statement at %C");
3297 s
.sym
->component_access
= ACCESS_PRIVATE
;
3299 accept_statement (ST_PRIVATE
);
3306 gfc_error ("SEQUENCE statement at %C must precede "
3307 "structure components");
3311 if (gfc_current_block ()->attr
.sequence
)
3312 gfc_warning (0, "SEQUENCE attribute at %C already specified in "
3317 gfc_error ("Duplicate SEQUENCE statement at %C");
3321 gfc_add_sequence (&gfc_current_block ()->attr
,
3322 gfc_current_block ()->name
, NULL
);
3326 gfc_notify_std (GFC_STD_F2003
,
3327 "CONTAINS block in derived type"
3328 " definition at %C");
3330 accept_statement (ST_CONTAINS
);
3331 parse_derived_contains ();
3335 unexpected_statement (st
);
3340 /* need to verify that all fields of the derived type are
3341 * interoperable with C if the type is declared to be bind(c)
3343 sym
= gfc_current_block ();
3344 for (c
= sym
->components
; c
; c
= c
->next
)
3345 check_component (sym
, c
, &lock_comp
, &event_comp
);
3347 if (!seen_component
)
3348 sym
->attr
.zero_comp
= 1;
3354 /* Parse an ENUM. */
3362 int seen_enumerator
= 0;
3364 push_state (&s
, COMP_ENUM
, gfc_new_block
);
3368 while (compiling_enum
)
3370 st
= next_statement ();
3378 seen_enumerator
= 1;
3379 accept_statement (st
);
3384 if (!seen_enumerator
)
3385 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
3386 accept_statement (st
);
3390 gfc_free_enum_history ();
3391 unexpected_statement (st
);
3399 /* Parse an interface. We must be able to deal with the possibility
3400 of recursive interfaces. The parse_spec() subroutine is mutually
3401 recursive with parse_interface(). */
3403 static gfc_statement
parse_spec (gfc_statement
);
3406 parse_interface (void)
3408 gfc_compile_state new_state
= COMP_NONE
, current_state
;
3409 gfc_symbol
*prog_unit
, *sym
;
3410 gfc_interface_info save
;
3411 gfc_state_data s1
, s2
;
3414 accept_statement (ST_INTERFACE
);
3416 current_interface
.ns
= gfc_current_ns
;
3417 save
= current_interface
;
3419 sym
= (current_interface
.type
== INTERFACE_GENERIC
3420 || current_interface
.type
== INTERFACE_USER_OP
)
3421 ? gfc_new_block
: NULL
;
3423 push_state (&s1
, COMP_INTERFACE
, sym
);
3424 current_state
= COMP_NONE
;
3427 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
3429 st
= next_statement ();
3437 if (st
== ST_SUBROUTINE
)
3438 new_state
= COMP_SUBROUTINE
;
3439 else if (st
== ST_FUNCTION
)
3440 new_state
= COMP_FUNCTION
;
3441 if (gfc_new_block
->attr
.pointer
)
3443 gfc_new_block
->attr
.pointer
= 0;
3444 gfc_new_block
->attr
.proc_pointer
= 1;
3446 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
3447 gfc_new_block
->formal
, NULL
))
3449 reject_statement ();
3450 gfc_free_namespace (gfc_current_ns
);
3453 /* F2008 C1210 forbids the IMPORT statement in module procedure
3454 interface bodies and the flag is set to import symbols. */
3455 if (gfc_new_block
->attr
.module_procedure
)
3456 gfc_current_ns
->has_import_set
= 1;
3460 case ST_MODULE_PROC
: /* The module procedure matcher makes
3461 sure the context is correct. */
3462 accept_statement (st
);
3463 gfc_free_namespace (gfc_current_ns
);
3466 case ST_END_INTERFACE
:
3467 gfc_free_namespace (gfc_current_ns
);
3468 gfc_current_ns
= current_interface
.ns
;
3472 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
3473 gfc_ascii_statement (st
));
3474 reject_statement ();
3475 gfc_free_namespace (gfc_current_ns
);
3480 /* Make sure that the generic name has the right attribute. */
3481 if (current_interface
.type
== INTERFACE_GENERIC
3482 && current_state
== COMP_NONE
)
3484 if (new_state
== COMP_FUNCTION
&& sym
)
3485 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
3486 else if (new_state
== COMP_SUBROUTINE
&& sym
)
3487 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
3489 current_state
= new_state
;
3492 if (current_interface
.type
== INTERFACE_ABSTRACT
)
3494 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
3495 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
3496 gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
3497 "cannot be the same as an intrinsic type",
3498 gfc_new_block
->name
);
3501 push_state (&s2
, new_state
, gfc_new_block
);
3502 accept_statement (st
);
3503 prog_unit
= gfc_new_block
;
3504 prog_unit
->formal_ns
= gfc_current_ns
;
3505 if (prog_unit
== prog_unit
->formal_ns
->proc_name
3506 && prog_unit
->ns
!= prog_unit
->formal_ns
)
3510 /* Read data declaration statements. */
3511 st
= parse_spec (ST_NONE
);
3512 in_specification_block
= true;
3514 /* Since the interface block does not permit an IMPLICIT statement,
3515 the default type for the function or the result must be taken
3516 from the formal namespace. */
3517 if (new_state
== COMP_FUNCTION
)
3519 if (prog_unit
->result
== prog_unit
3520 && prog_unit
->ts
.type
== BT_UNKNOWN
)
3521 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
3522 else if (prog_unit
->result
!= prog_unit
3523 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
3524 gfc_set_default_type (prog_unit
->result
, 1,
3525 prog_unit
->formal_ns
);
3528 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
3530 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
3531 gfc_ascii_statement (st
));
3532 reject_statement ();
3536 /* Add EXTERNAL attribute to function or subroutine. */
3537 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
3538 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
3540 current_interface
= save
;
3541 gfc_add_interface (prog_unit
);
3544 if (current_interface
.ns
3545 && current_interface
.ns
->proc_name
3546 && strcmp (current_interface
.ns
->proc_name
->name
,
3547 prog_unit
->name
) == 0)
3548 gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
3549 "enclosing procedure", prog_unit
->name
,
3550 ¤t_interface
.ns
->proc_name
->declared_at
);
3559 /* Associate function characteristics by going back to the function
3560 declaration and rematching the prefix. */
3563 match_deferred_characteristics (gfc_typespec
* ts
)
3566 match m
= MATCH_ERROR
;
3567 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3569 loc
= gfc_current_locus
;
3571 gfc_current_locus
= gfc_current_block ()->declared_at
;
3574 gfc_buffer_error (true);
3575 m
= gfc_match_prefix (ts
);
3576 gfc_buffer_error (false);
3578 if (ts
->type
== BT_DERIVED
)
3586 /* Only permit one go at the characteristic association. */
3590 /* Set the function locus correctly. If we have not found the
3591 function name, there is an error. */
3593 && gfc_match ("function% %n", name
) == MATCH_YES
3594 && strcmp (name
, gfc_current_block ()->name
) == 0)
3596 gfc_current_block ()->declared_at
= gfc_current_locus
;
3597 gfc_commit_symbols ();
3602 gfc_undo_symbols ();
3605 gfc_current_locus
=loc
;
3610 /* Check specification-expressions in the function result of the currently
3611 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
3612 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
3613 scope are not yet parsed so this has to be delayed up to parse_spec. */
3616 check_function_result_typed (void)
3620 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
3622 if (!gfc_current_ns
->proc_name
->result
) return;
3624 ts
= gfc_current_ns
->proc_name
->result
->ts
;
3626 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
3627 /* TODO: Extend when KIND type parameters are implemented. */
3628 if (ts
.type
== BT_CHARACTER
&& ts
.u
.cl
&& ts
.u
.cl
->length
)
3629 gfc_expr_check_typed (ts
.u
.cl
->length
, gfc_current_ns
, true);
3633 /* Parse a set of specification statements. Returns the statement
3634 that doesn't fit. */
3636 static gfc_statement
3637 parse_spec (gfc_statement st
)
3640 bool function_result_typed
= false;
3641 bool bad_characteristic
= false;
3644 in_specification_block
= true;
3646 verify_st_order (&ss
, ST_NONE
, false);
3648 st
= next_statement ();
3650 /* If we are not inside a function or don't have a result specified so far,
3651 do nothing special about it. */
3652 if (gfc_current_state () != COMP_FUNCTION
)
3653 function_result_typed
= true;
3656 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
3659 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
3660 function_result_typed
= true;
3665 /* If we're inside a BLOCK construct, some statements are disallowed.
3666 Check this here. Attribute declaration statements like INTENT, OPTIONAL
3667 or VALUE are also disallowed, but they don't have a particular ST_*
3668 key so we have to check for them individually in their matcher routine. */
3669 if (gfc_current_state () == COMP_BLOCK
)
3673 case ST_IMPLICIT_NONE
:
3676 case ST_EQUIVALENCE
:
3677 case ST_STATEMENT_FUNCTION
:
3678 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
3679 gfc_ascii_statement (st
));
3680 reject_statement ();
3686 else if (gfc_current_state () == COMP_BLOCK_DATA
)
3687 /* Fortran 2008, C1116. */
3694 case ST_DERIVED_DECL
:
3695 case ST_END_BLOCK_DATA
:
3696 case ST_EQUIVALENCE
:
3698 case ST_IMPLICIT_NONE
:
3700 case ST_STRUCTURE_DECL
:
3709 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
3710 gfc_ascii_statement (st
));
3711 reject_statement ();
3715 /* If we find a statement that can not be followed by an IMPLICIT statement
3716 (and thus we can expect to see none any further), type the function result
3717 if it has not yet been typed. Be careful not to give the END statement
3718 to verify_st_order! */
3719 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
3721 bool verify_now
= false;
3723 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
3728 verify_st_order (&dummyss
, ST_NONE
, false);
3729 verify_st_order (&dummyss
, st
, false);
3731 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
3737 check_function_result_typed ();
3738 function_result_typed
= true;
3747 case ST_IMPLICIT_NONE
:
3749 if (!function_result_typed
)
3751 check_function_result_typed ();
3752 function_result_typed
= true;
3758 case ST_DATA
: /* Not allowed in interfaces */
3759 if (gfc_current_state () == COMP_INTERFACE
)
3769 case ST_STRUCTURE_DECL
:
3770 case ST_DERIVED_DECL
:
3774 if (!verify_st_order (&ss
, st
, false))
3776 reject_statement ();
3777 st
= next_statement ();
3787 case ST_STRUCTURE_DECL
:
3788 parse_struct_map (ST_STRUCTURE_DECL
);
3791 case ST_DERIVED_DECL
:
3797 if (gfc_current_state () != COMP_MODULE
)
3799 gfc_error ("%s statement must appear in a MODULE",
3800 gfc_ascii_statement (st
));
3801 reject_statement ();
3805 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
3807 gfc_error ("%s statement at %C follows another accessibility "
3808 "specification", gfc_ascii_statement (st
));
3809 reject_statement ();
3813 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
3814 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3818 case ST_STATEMENT_FUNCTION
:
3819 if (gfc_current_state () == COMP_MODULE
3820 || gfc_current_state () == COMP_SUBMODULE
)
3822 unexpected_statement (st
);
3830 accept_statement (st
);
3831 st
= next_statement ();
3835 accept_statement (st
);
3837 st
= next_statement ();
3840 case ST_GET_FCN_CHARACTERISTICS
:
3841 /* This statement triggers the association of a function's result
3843 ts
= &gfc_current_block ()->result
->ts
;
3844 if (match_deferred_characteristics (ts
) != MATCH_YES
)
3845 bad_characteristic
= true;
3847 st
= next_statement ();
3854 /* If match_deferred_characteristics failed, then there is an error. */
3855 if (bad_characteristic
)
3857 ts
= &gfc_current_block ()->result
->ts
;
3858 if (ts
->type
!= BT_DERIVED
)
3859 gfc_error ("Bad kind expression for function %qs at %L",
3860 gfc_current_block ()->name
,
3861 &gfc_current_block ()->declared_at
);
3863 gfc_error ("The type for function %qs at %L is not accessible",
3864 gfc_current_block ()->name
,
3865 &gfc_current_block ()->declared_at
);
3867 gfc_current_block ()->ts
.kind
= 0;
3868 /* Keep the derived type; if it's bad, it will be discovered later. */
3869 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
3870 ts
->type
= BT_UNKNOWN
;
3873 in_specification_block
= false;
3879 /* Parse a WHERE block, (not a simple WHERE statement). */
3882 parse_where_block (void)
3884 int seen_empty_else
;
3889 accept_statement (ST_WHERE_BLOCK
);
3890 top
= gfc_state_stack
->tail
;
3892 push_state (&s
, COMP_WHERE
, gfc_new_block
);
3894 d
= add_statement ();
3895 d
->expr1
= top
->expr1
;
3901 seen_empty_else
= 0;
3905 st
= next_statement ();
3911 case ST_WHERE_BLOCK
:
3912 parse_where_block ();
3917 accept_statement (st
);
3921 if (seen_empty_else
)
3923 gfc_error ("ELSEWHERE statement at %C follows previous "
3924 "unmasked ELSEWHERE");
3925 reject_statement ();
3929 if (new_st
.expr1
== NULL
)
3930 seen_empty_else
= 1;
3932 d
= new_level (gfc_state_stack
->head
);
3934 d
->expr1
= new_st
.expr1
;
3936 accept_statement (st
);
3941 accept_statement (st
);
3945 gfc_error ("Unexpected %s statement in WHERE block at %C",
3946 gfc_ascii_statement (st
));
3947 reject_statement ();
3951 while (st
!= ST_END_WHERE
);
3957 /* Parse a FORALL block (not a simple FORALL statement). */
3960 parse_forall_block (void)
3966 accept_statement (ST_FORALL_BLOCK
);
3967 top
= gfc_state_stack
->tail
;
3969 push_state (&s
, COMP_FORALL
, gfc_new_block
);
3971 d
= add_statement ();
3972 d
->op
= EXEC_FORALL
;
3977 st
= next_statement ();
3982 case ST_POINTER_ASSIGNMENT
:
3985 accept_statement (st
);
3988 case ST_WHERE_BLOCK
:
3989 parse_where_block ();
3992 case ST_FORALL_BLOCK
:
3993 parse_forall_block ();
3997 accept_statement (st
);
4004 gfc_error ("Unexpected %s statement in FORALL block at %C",
4005 gfc_ascii_statement (st
));
4007 reject_statement ();
4011 while (st
!= ST_END_FORALL
);
4017 static gfc_statement
parse_executable (gfc_statement
);
4019 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
4022 parse_if_block (void)
4031 accept_statement (ST_IF_BLOCK
);
4033 top
= gfc_state_stack
->tail
;
4034 push_state (&s
, COMP_IF
, gfc_new_block
);
4036 new_st
.op
= EXEC_IF
;
4037 d
= add_statement ();
4039 d
->expr1
= top
->expr1
;
4045 st
= parse_executable (ST_NONE
);
4055 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
4056 "statement at %L", &else_locus
);
4058 reject_statement ();
4062 d
= new_level (gfc_state_stack
->head
);
4064 d
->expr1
= new_st
.expr1
;
4066 accept_statement (st
);
4073 gfc_error ("Duplicate ELSE statements at %L and %C",
4075 reject_statement ();
4080 else_locus
= gfc_current_locus
;
4082 d
= new_level (gfc_state_stack
->head
);
4085 accept_statement (st
);
4093 unexpected_statement (st
);
4097 while (st
!= ST_ENDIF
);
4100 accept_statement (st
);
4104 /* Parse a SELECT block. */
4107 parse_select_block (void)
4113 accept_statement (ST_SELECT_CASE
);
4115 cp
= gfc_state_stack
->tail
;
4116 push_state (&s
, COMP_SELECT
, gfc_new_block
);
4118 /* Make sure that the next statement is a CASE or END SELECT. */
4121 st
= next_statement ();
4124 if (st
== ST_END_SELECT
)
4126 /* Empty SELECT CASE is OK. */
4127 accept_statement (st
);
4134 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
4137 reject_statement ();
4140 /* At this point, we're got a nonempty select block. */
4141 cp
= new_level (cp
);
4144 accept_statement (st
);
4148 st
= parse_executable (ST_NONE
);
4155 cp
= new_level (gfc_state_stack
->head
);
4157 gfc_clear_new_st ();
4159 accept_statement (st
);
4165 /* Can't have an executable statement because of
4166 parse_executable(). */
4168 unexpected_statement (st
);
4172 while (st
!= ST_END_SELECT
);
4175 accept_statement (st
);
4179 /* Pop the current selector from the SELECT TYPE stack. */
4182 select_type_pop (void)
4184 gfc_select_type_stack
*old
= select_type_stack
;
4185 select_type_stack
= old
->prev
;
4190 /* Parse a SELECT TYPE construct (F03:R821). */
4193 parse_select_type_block (void)
4199 gfc_current_ns
= new_st
.ext
.block
.ns
;
4200 accept_statement (ST_SELECT_TYPE
);
4202 cp
= gfc_state_stack
->tail
;
4203 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
4205 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
4209 st
= next_statement ();
4212 if (st
== ST_END_SELECT
)
4213 /* Empty SELECT CASE is OK. */
4215 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
4218 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
4219 "following SELECT TYPE at %C");
4221 reject_statement ();
4224 /* At this point, we're got a nonempty select block. */
4225 cp
= new_level (cp
);
4228 accept_statement (st
);
4232 st
= parse_executable (ST_NONE
);
4240 cp
= new_level (gfc_state_stack
->head
);
4242 gfc_clear_new_st ();
4244 accept_statement (st
);
4250 /* Can't have an executable statement because of
4251 parse_executable(). */
4253 unexpected_statement (st
);
4257 while (st
!= ST_END_SELECT
);
4261 accept_statement (st
);
4262 gfc_current_ns
= gfc_current_ns
->parent
;
4267 /* Given a symbol, make sure it is not an iteration variable for a DO
4268 statement. This subroutine is called when the symbol is seen in a
4269 context that causes it to become redefined. If the symbol is an
4270 iterator, we generate an error message and return nonzero. */
4273 gfc_check_do_variable (gfc_symtree
*st
)
4277 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
4278 if (s
->do_variable
== st
)
4280 gfc_error_now ("Variable %qs at %C cannot be redefined inside "
4281 "loop beginning at %L", st
->name
, &s
->head
->loc
);
4289 /* Checks to see if the current statement label closes an enddo.
4290 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
4291 an error) if it incorrectly closes an ENDDO. */
4294 check_do_closure (void)
4298 if (gfc_statement_label
== NULL
)
4301 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
4302 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4306 return 0; /* No loops to close */
4308 if (p
->ext
.end_do_label
== gfc_statement_label
)
4310 if (p
== gfc_state_stack
)
4313 gfc_error ("End of nonblock DO statement at %C is within another block");
4317 /* At this point, the label doesn't terminate the innermost loop.
4318 Make sure it doesn't terminate another one. */
4319 for (; p
; p
= p
->previous
)
4320 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4321 && p
->ext
.end_do_label
== gfc_statement_label
)
4323 gfc_error ("End of nonblock DO statement at %C is interwoven "
4324 "with another DO loop");
4332 /* Parse a series of contained program units. */
4334 static void parse_progunit (gfc_statement
);
4337 /* Parse a CRITICAL block. */
4340 parse_critical_block (void)
4343 gfc_state_data s
, *sd
;
4346 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4347 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
4348 gfc_error_now (is_oacc (sd
)
4349 ? G_("CRITICAL block inside of OpenACC region at %C")
4350 : G_("CRITICAL block inside of OpenMP region at %C"));
4352 s
.ext
.end_do_label
= new_st
.label1
;
4354 accept_statement (ST_CRITICAL
);
4355 top
= gfc_state_stack
->tail
;
4357 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
4359 d
= add_statement ();
4360 d
->op
= EXEC_CRITICAL
;
4365 st
= parse_executable (ST_NONE
);
4373 case ST_END_CRITICAL
:
4374 if (s
.ext
.end_do_label
!= NULL
4375 && s
.ext
.end_do_label
!= gfc_statement_label
)
4376 gfc_error_now ("Statement label in END CRITICAL at %C does not "
4377 "match CRITICAL label");
4379 if (gfc_statement_label
!= NULL
)
4381 new_st
.op
= EXEC_NOP
;
4387 unexpected_statement (st
);
4391 while (st
!= ST_END_CRITICAL
);
4394 accept_statement (st
);
4398 /* Set up the local namespace for a BLOCK construct. */
4401 gfc_build_block_ns (gfc_namespace
*parent_ns
)
4403 gfc_namespace
* my_ns
;
4404 static int numblock
= 1;
4406 my_ns
= gfc_get_namespace (parent_ns
, 1);
4407 my_ns
->construct_entities
= 1;
4409 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
4410 code generation (so it must not be NULL).
4411 We set its recursive argument if our container procedure is recursive, so
4412 that local variables are accordingly placed on the stack when it
4413 will be necessary. */
4415 my_ns
->proc_name
= gfc_new_block
;
4419 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
4421 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
4422 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
4423 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
4424 my_ns
->proc_name
->name
, NULL
);
4426 gfc_commit_symbol (my_ns
->proc_name
);
4429 if (parent_ns
->proc_name
)
4430 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
4436 /* Parse a BLOCK construct. */
4439 parse_block_construct (void)
4441 gfc_namespace
* my_ns
;
4442 gfc_namespace
* my_parent
;
4445 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
4447 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4449 new_st
.op
= EXEC_BLOCK
;
4450 new_st
.ext
.block
.ns
= my_ns
;
4451 new_st
.ext
.block
.assoc
= NULL
;
4452 accept_statement (ST_BLOCK
);
4454 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
4455 gfc_current_ns
= my_ns
;
4456 my_parent
= my_ns
->parent
;
4458 parse_progunit (ST_NONE
);
4460 /* Don't depend on the value of gfc_current_ns; it might have been
4461 reset if the block had errors and was cleaned up. */
4462 gfc_current_ns
= my_parent
;
4468 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
4469 behind the scenes with compiler-generated variables. */
4472 parse_associate (void)
4474 gfc_namespace
* my_ns
;
4477 gfc_association_list
* a
;
4479 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
4481 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4483 new_st
.op
= EXEC_BLOCK
;
4484 new_st
.ext
.block
.ns
= my_ns
;
4485 gcc_assert (new_st
.ext
.block
.assoc
);
4487 /* Add all associate-names as BLOCK variables. Creating them is enough
4488 for now, they'll get their values during trans-* phase. */
4489 gfc_current_ns
= my_ns
;
4490 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
4494 gfc_array_ref
*array_ref
;
4496 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
4500 sym
->attr
.flavor
= FL_VARIABLE
;
4502 sym
->declared_at
= a
->where
;
4503 gfc_set_sym_referenced (sym
);
4505 /* Initialize the typespec. It is not available in all cases,
4506 however, as it may only be set on the target during resolution.
4507 Still, sometimes it helps to have it right now -- especially
4508 for parsing component references on the associate-name
4509 in case of association to a derived-type. */
4510 sym
->ts
= a
->target
->ts
;
4512 /* Check if the target expression is array valued. This can not always
4513 be done by looking at target.rank, because that might not have been
4514 set yet. Therefore traverse the chain of refs, looking for the last
4515 array ref and evaluate that. */
4517 for (ref
= a
->target
->ref
; ref
; ref
= ref
->next
)
4518 if (ref
->type
== REF_ARRAY
)
4519 array_ref
= &ref
->u
.ar
;
4520 if (array_ref
|| a
->target
->rank
)
4527 /* Count the dimension, that have a non-scalar extend. */
4528 for (dim
= 0; dim
< array_ref
->dimen
; ++dim
)
4529 if (array_ref
->dimen_type
[dim
] != DIMEN_ELEMENT
4530 && !(array_ref
->dimen_type
[dim
] == DIMEN_UNKNOWN
4531 && array_ref
->end
[dim
] == NULL
4532 && array_ref
->start
[dim
] != NULL
))
4536 rank
= a
->target
->rank
;
4537 /* When the rank is greater than zero then sym will be an array. */
4538 if (sym
->ts
.type
== BT_CLASS
)
4540 if ((!CLASS_DATA (sym
)->as
&& rank
!= 0)
4541 || (CLASS_DATA (sym
)->as
4542 && CLASS_DATA (sym
)->as
->rank
!= rank
))
4544 /* Don't just (re-)set the attr and as in the sym.ts,
4545 because this modifies the target's attr and as. Copy the
4546 data and do a build_class_symbol. */
4547 symbol_attribute attr
= CLASS_DATA (a
->target
)->attr
;
4548 int corank
= gfc_get_corank (a
->target
);
4553 as
= gfc_get_array_spec ();
4554 as
->type
= AS_DEFERRED
;
4556 as
->corank
= corank
;
4557 attr
.dimension
= rank
? 1 : 0;
4558 attr
.codimension
= corank
? 1 : 0;
4563 attr
.dimension
= attr
.codimension
= 0;
4566 type
= CLASS_DATA (sym
)->ts
;
4567 if (!gfc_build_class_symbol (&type
,
4571 sym
->ts
.type
= BT_CLASS
;
4572 sym
->attr
.class_ok
= 1;
4575 sym
->attr
.class_ok
= 1;
4577 else if ((!sym
->as
&& rank
!= 0)
4578 || (sym
->as
&& sym
->as
->rank
!= rank
))
4580 as
= gfc_get_array_spec ();
4581 as
->type
= AS_DEFERRED
;
4583 as
->corank
= gfc_get_corank (a
->target
);
4585 sym
->attr
.dimension
= 1;
4587 sym
->attr
.codimension
= 1;
4592 accept_statement (ST_ASSOCIATE
);
4593 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
4596 st
= parse_executable (ST_NONE
);
4603 accept_statement (st
);
4604 my_ns
->code
= gfc_state_stack
->head
;
4608 unexpected_statement (st
);
4612 gfc_current_ns
= gfc_current_ns
->parent
;
4617 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
4618 handled inside of parse_executable(), because they aren't really
4622 parse_do_block (void)
4631 s
.ext
.end_do_label
= new_st
.label1
;
4633 if (new_st
.ext
.iterator
!= NULL
)
4634 stree
= new_st
.ext
.iterator
->var
->symtree
;
4638 accept_statement (ST_DO
);
4640 top
= gfc_state_stack
->tail
;
4641 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
4644 s
.do_variable
= stree
;
4646 top
->block
= new_level (top
);
4647 top
->block
->op
= EXEC_DO
;
4650 st
= parse_executable (ST_NONE
);
4658 if (s
.ext
.end_do_label
!= NULL
4659 && s
.ext
.end_do_label
!= gfc_statement_label
)
4660 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
4663 if (gfc_statement_label
!= NULL
)
4665 new_st
.op
= EXEC_NOP
;
4670 case ST_IMPLIED_ENDDO
:
4671 /* If the do-stmt of this DO construct has a do-construct-name,
4672 the corresponding end-do must be an end-do-stmt (with a matching
4673 name, but in that case we must have seen ST_ENDDO first).
4674 We only complain about this in pedantic mode. */
4675 if (gfc_current_block () != NULL
)
4676 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
4677 &gfc_current_block()->declared_at
);
4682 unexpected_statement (st
);
4687 accept_statement (st
);
4691 /* Parse the statements of OpenMP do/parallel do. */
4693 static gfc_statement
4694 parse_omp_do (gfc_statement omp_st
)
4700 accept_statement (omp_st
);
4702 cp
= gfc_state_stack
->tail
;
4703 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4704 np
= new_level (cp
);
4710 st
= next_statement ();
4713 else if (st
== ST_DO
)
4716 unexpected_statement (st
);
4720 if (gfc_statement_label
!= NULL
4721 && gfc_state_stack
->previous
!= NULL
4722 && gfc_state_stack
->previous
->state
== COMP_DO
4723 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4731 there should be no !$OMP END DO. */
4733 return ST_IMPLIED_ENDDO
;
4736 check_do_closure ();
4739 st
= next_statement ();
4740 gfc_statement omp_end_st
= ST_OMP_END_DO
;
4743 case ST_OMP_DISTRIBUTE
: omp_end_st
= ST_OMP_END_DISTRIBUTE
; break;
4744 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4745 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4747 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4748 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4750 case ST_OMP_DISTRIBUTE_SIMD
:
4751 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4753 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
4754 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
4755 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
4756 case ST_OMP_PARALLEL_DO_SIMD
:
4757 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
4759 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
4760 case ST_OMP_TARGET_PARALLEL_DO
:
4761 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO
;
4763 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
4764 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO_SIMD
;
4766 case ST_OMP_TARGET_SIMD
: omp_end_st
= ST_OMP_END_TARGET_SIMD
; break;
4767 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4768 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4770 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4771 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4773 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4774 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4776 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4777 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4779 case ST_OMP_TASKLOOP
: omp_end_st
= ST_OMP_END_TASKLOOP
; break;
4780 case ST_OMP_TASKLOOP_SIMD
: omp_end_st
= ST_OMP_END_TASKLOOP_SIMD
; break;
4781 case ST_OMP_TEAMS_DISTRIBUTE
:
4782 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4784 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4785 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4787 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4788 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4790 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4791 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4793 default: gcc_unreachable ();
4795 if (st
== omp_end_st
)
4797 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
4798 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4800 gcc_assert (new_st
.op
== EXEC_NOP
);
4801 gfc_clear_new_st ();
4802 gfc_commit_symbols ();
4803 gfc_warning_check ();
4804 st
= next_statement ();
4810 /* Parse the statements of OpenMP atomic directive. */
4812 static gfc_statement
4813 parse_omp_oacc_atomic (bool omp_p
)
4815 gfc_statement st
, st_atomic
, st_end_atomic
;
4822 st_atomic
= ST_OMP_ATOMIC
;
4823 st_end_atomic
= ST_OMP_END_ATOMIC
;
4827 st_atomic
= ST_OACC_ATOMIC
;
4828 st_end_atomic
= ST_OACC_END_ATOMIC
;
4830 accept_statement (st_atomic
);
4832 cp
= gfc_state_stack
->tail
;
4833 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4834 np
= new_level (cp
);
4837 np
->ext
.omp_atomic
= cp
->ext
.omp_atomic
;
4838 count
= 1 + ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4839 == GFC_OMP_ATOMIC_CAPTURE
);
4843 st
= next_statement ();
4846 else if (st
== ST_ASSIGNMENT
)
4848 accept_statement (st
);
4852 unexpected_statement (st
);
4857 st
= next_statement ();
4858 if (st
== st_end_atomic
)
4860 gfc_clear_new_st ();
4861 gfc_commit_symbols ();
4862 gfc_warning_check ();
4863 st
= next_statement ();
4865 else if ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4866 == GFC_OMP_ATOMIC_CAPTURE
)
4867 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
4872 /* Parse the statements of an OpenACC structured block. */
4875 parse_oacc_structured_block (gfc_statement acc_st
)
4877 gfc_statement st
, acc_end_st
;
4879 gfc_state_data s
, *sd
;
4881 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4882 if (sd
->state
== COMP_CRITICAL
)
4883 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4885 accept_statement (acc_st
);
4887 cp
= gfc_state_stack
->tail
;
4888 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4889 np
= new_level (cp
);
4894 case ST_OACC_PARALLEL
:
4895 acc_end_st
= ST_OACC_END_PARALLEL
;
4897 case ST_OACC_KERNELS
:
4898 acc_end_st
= ST_OACC_END_KERNELS
;
4901 acc_end_st
= ST_OACC_END_DATA
;
4903 case ST_OACC_HOST_DATA
:
4904 acc_end_st
= ST_OACC_END_HOST_DATA
;
4912 st
= parse_executable (ST_NONE
);
4915 else if (st
!= acc_end_st
)
4917 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
4918 reject_statement ();
4921 while (st
!= acc_end_st
);
4923 gcc_assert (new_st
.op
== EXEC_NOP
);
4925 gfc_clear_new_st ();
4926 gfc_commit_symbols ();
4927 gfc_warning_check ();
4931 /* Parse the statements of OpenACC loop/parallel loop/kernels loop. */
4933 static gfc_statement
4934 parse_oacc_loop (gfc_statement acc_st
)
4938 gfc_state_data s
, *sd
;
4940 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4941 if (sd
->state
== COMP_CRITICAL
)
4942 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4944 accept_statement (acc_st
);
4946 cp
= gfc_state_stack
->tail
;
4947 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4948 np
= new_level (cp
);
4954 st
= next_statement ();
4957 else if (st
== ST_DO
)
4961 gfc_error ("Expected DO loop at %C");
4962 reject_statement ();
4967 if (gfc_statement_label
!= NULL
4968 && gfc_state_stack
->previous
!= NULL
4969 && gfc_state_stack
->previous
->state
== COMP_DO
4970 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4973 return ST_IMPLIED_ENDDO
;
4976 check_do_closure ();
4979 st
= next_statement ();
4980 if (st
== ST_OACC_END_LOOP
)
4981 gfc_warning (0, "Redundant !$ACC END LOOP at %C");
4982 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
4983 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
4984 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
4986 gcc_assert (new_st
.op
== EXEC_NOP
);
4987 gfc_clear_new_st ();
4988 gfc_commit_symbols ();
4989 gfc_warning_check ();
4990 st
= next_statement ();
4996 /* Parse the statements of an OpenMP structured block. */
4999 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
5001 gfc_statement st
, omp_end_st
;
5005 accept_statement (omp_st
);
5007 cp
= gfc_state_stack
->tail
;
5008 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5009 np
= new_level (cp
);
5015 case ST_OMP_PARALLEL
:
5016 omp_end_st
= ST_OMP_END_PARALLEL
;
5018 case ST_OMP_PARALLEL_SECTIONS
:
5019 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
5021 case ST_OMP_SECTIONS
:
5022 omp_end_st
= ST_OMP_END_SECTIONS
;
5024 case ST_OMP_ORDERED
:
5025 omp_end_st
= ST_OMP_END_ORDERED
;
5027 case ST_OMP_CRITICAL
:
5028 omp_end_st
= ST_OMP_END_CRITICAL
;
5031 omp_end_st
= ST_OMP_END_MASTER
;
5034 omp_end_st
= ST_OMP_END_SINGLE
;
5037 omp_end_st
= ST_OMP_END_TARGET
;
5039 case ST_OMP_TARGET_DATA
:
5040 omp_end_st
= ST_OMP_END_TARGET_DATA
;
5042 case ST_OMP_TARGET_TEAMS
:
5043 omp_end_st
= ST_OMP_END_TARGET_TEAMS
;
5045 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5046 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
5048 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5049 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5051 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5052 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5054 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5055 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
5058 omp_end_st
= ST_OMP_END_TASK
;
5060 case ST_OMP_TASKGROUP
:
5061 omp_end_st
= ST_OMP_END_TASKGROUP
;
5064 omp_end_st
= ST_OMP_END_TEAMS
;
5066 case ST_OMP_TEAMS_DISTRIBUTE
:
5067 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
5069 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5070 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5072 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5073 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5075 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5076 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
5078 case ST_OMP_DISTRIBUTE
:
5079 omp_end_st
= ST_OMP_END_DISTRIBUTE
;
5081 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5082 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
5084 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5085 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
5087 case ST_OMP_DISTRIBUTE_SIMD
:
5088 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
5090 case ST_OMP_WORKSHARE
:
5091 omp_end_st
= ST_OMP_END_WORKSHARE
;
5093 case ST_OMP_PARALLEL_WORKSHARE
:
5094 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
5102 if (workshare_stmts_only
)
5104 /* Inside of !$omp workshare, only
5107 where statements and constructs
5108 forall statements and constructs
5112 are allowed. For !$omp critical these
5113 restrictions apply recursively. */
5116 st
= next_statement ();
5127 accept_statement (st
);
5130 case ST_WHERE_BLOCK
:
5131 parse_where_block ();
5134 case ST_FORALL_BLOCK
:
5135 parse_forall_block ();
5138 case ST_OMP_PARALLEL
:
5139 case ST_OMP_PARALLEL_SECTIONS
:
5140 parse_omp_structured_block (st
, false);
5143 case ST_OMP_PARALLEL_WORKSHARE
:
5144 case ST_OMP_CRITICAL
:
5145 parse_omp_structured_block (st
, true);
5148 case ST_OMP_PARALLEL_DO
:
5149 case ST_OMP_PARALLEL_DO_SIMD
:
5150 st
= parse_omp_do (st
);
5154 st
= parse_omp_oacc_atomic (true);
5165 st
= next_statement ();
5169 st
= parse_executable (ST_NONE
);
5172 else if (st
== ST_OMP_SECTION
5173 && (omp_st
== ST_OMP_SECTIONS
5174 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
5176 np
= new_level (np
);
5180 else if (st
!= omp_end_st
)
5181 unexpected_statement (st
);
5183 while (st
!= omp_end_st
);
5187 case EXEC_OMP_END_NOWAIT
:
5188 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
5190 case EXEC_OMP_END_CRITICAL
:
5191 if (((cp
->ext
.omp_clauses
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
5192 || (new_st
.ext
.omp_name
!= NULL
5193 && strcmp (cp
->ext
.omp_clauses
->critical_name
,
5194 new_st
.ext
.omp_name
) != 0))
5195 gfc_error ("Name after !$omp critical and !$omp end critical does "
5197 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
5198 new_st
.ext
.omp_name
= NULL
;
5200 case EXEC_OMP_END_SINGLE
:
5201 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
5202 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
5203 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
5204 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
5212 gfc_clear_new_st ();
5213 gfc_commit_symbols ();
5214 gfc_warning_check ();
5219 /* Accept a series of executable statements. We return the first
5220 statement that doesn't fit to the caller. Any block statements are
5221 passed on to the correct handler, which usually passes the buck
5224 static gfc_statement
5225 parse_executable (gfc_statement st
)
5230 st
= next_statement ();
5234 close_flag
= check_do_closure ();
5239 case ST_END_PROGRAM
:
5242 case ST_END_FUNCTION
:
5247 case ST_END_SUBROUTINE
:
5252 case ST_SELECT_CASE
:
5253 gfc_error ("%s statement at %C cannot terminate a non-block "
5254 "DO loop", gfc_ascii_statement (st
));
5267 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
5268 "first executable statement");
5274 accept_statement (st
);
5275 if (close_flag
== 1)
5276 return ST_IMPLIED_ENDDO
;
5280 parse_block_construct ();
5291 case ST_SELECT_CASE
:
5292 parse_select_block ();
5295 case ST_SELECT_TYPE
:
5296 parse_select_type_block ();
5301 if (check_do_closure () == 1)
5302 return ST_IMPLIED_ENDDO
;
5306 parse_critical_block ();
5309 case ST_WHERE_BLOCK
:
5310 parse_where_block ();
5313 case ST_FORALL_BLOCK
:
5314 parse_forall_block ();
5317 case ST_OACC_PARALLEL_LOOP
:
5318 case ST_OACC_KERNELS_LOOP
:
5320 st
= parse_oacc_loop (st
);
5321 if (st
== ST_IMPLIED_ENDDO
)
5325 case ST_OACC_PARALLEL
:
5326 case ST_OACC_KERNELS
:
5328 case ST_OACC_HOST_DATA
:
5329 parse_oacc_structured_block (st
);
5332 case ST_OMP_PARALLEL
:
5333 case ST_OMP_PARALLEL_SECTIONS
:
5334 case ST_OMP_SECTIONS
:
5335 case ST_OMP_ORDERED
:
5336 case ST_OMP_CRITICAL
:
5340 case ST_OMP_TARGET_DATA
:
5341 case ST_OMP_TARGET_PARALLEL
:
5342 case ST_OMP_TARGET_TEAMS
:
5345 case ST_OMP_TASKGROUP
:
5346 parse_omp_structured_block (st
, false);
5349 case ST_OMP_WORKSHARE
:
5350 case ST_OMP_PARALLEL_WORKSHARE
:
5351 parse_omp_structured_block (st
, true);
5354 case ST_OMP_DISTRIBUTE
:
5355 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5356 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5357 case ST_OMP_DISTRIBUTE_SIMD
:
5359 case ST_OMP_DO_SIMD
:
5360 case ST_OMP_PARALLEL_DO
:
5361 case ST_OMP_PARALLEL_DO_SIMD
:
5363 case ST_OMP_TARGET_PARALLEL_DO
:
5364 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
5365 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5366 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5367 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5368 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5369 case ST_OMP_TASKLOOP
:
5370 case ST_OMP_TASKLOOP_SIMD
:
5371 case ST_OMP_TEAMS_DISTRIBUTE
:
5372 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5373 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5374 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5375 st
= parse_omp_do (st
);
5376 if (st
== ST_IMPLIED_ENDDO
)
5380 case ST_OACC_ATOMIC
:
5381 st
= parse_omp_oacc_atomic (false);
5385 st
= parse_omp_oacc_atomic (true);
5392 st
= next_statement ();
5397 /* Fix the symbols for sibling functions. These are incorrectly added to
5398 the child namespace as the parser didn't know about this procedure. */
5401 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
5405 gfc_symbol
*old_sym
;
5407 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
5409 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
5411 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
5412 goto fixup_contained
;
5414 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
5415 && sym
->attr
.generic
&& sym
->attr
.function
)
5416 ||(sym
->attr
.flavor
== FL_DERIVED
5417 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
5418 goto fixup_contained
;
5420 old_sym
= st
->n
.sym
;
5421 if (old_sym
->ns
== ns
5422 && !old_sym
->attr
.contained
5424 /* By 14.6.1.3, host association should be excluded
5425 for the following. */
5426 && !(old_sym
->attr
.external
5427 || (old_sym
->ts
.type
!= BT_UNKNOWN
5428 && !old_sym
->attr
.implicit_type
)
5429 || old_sym
->attr
.flavor
== FL_PARAMETER
5430 || old_sym
->attr
.use_assoc
5431 || old_sym
->attr
.in_common
5432 || old_sym
->attr
.in_equivalence
5433 || old_sym
->attr
.data
5434 || old_sym
->attr
.dummy
5435 || old_sym
->attr
.result
5436 || old_sym
->attr
.dimension
5437 || old_sym
->attr
.allocatable
5438 || old_sym
->attr
.intrinsic
5439 || old_sym
->attr
.generic
5440 || old_sym
->attr
.flavor
== FL_NAMELIST
5441 || old_sym
->attr
.flavor
== FL_LABEL
5442 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
5444 /* Replace it with the symbol from the parent namespace. */
5448 gfc_release_symbol (old_sym
);
5452 /* Do the same for any contained procedures. */
5453 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
5458 parse_contained (int module
)
5460 gfc_namespace
*ns
, *parent_ns
, *tmp
;
5461 gfc_state_data s1
, s2
;
5466 int contains_statements
= 0;
5469 push_state (&s1
, COMP_CONTAINS
, NULL
);
5470 parent_ns
= gfc_current_ns
;
5474 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
5476 gfc_current_ns
->sibling
= parent_ns
->contained
;
5477 parent_ns
->contained
= gfc_current_ns
;
5480 /* Process the next available statement. We come here if we got an error
5481 and rejected the last statement. */
5482 old_loc
= gfc_current_locus
;
5483 st
= next_statement ();
5492 contains_statements
= 1;
5493 accept_statement (st
);
5496 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
5499 /* For internal procedures, create/update the symbol in the
5500 parent namespace. */
5504 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
5505 gfc_error ("Contained procedure %qs at %C is already "
5506 "ambiguous", gfc_new_block
->name
);
5509 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
5511 &gfc_new_block
->declared_at
))
5513 if (st
== ST_FUNCTION
)
5514 gfc_add_function (&sym
->attr
, sym
->name
,
5515 &gfc_new_block
->declared_at
);
5517 gfc_add_subroutine (&sym
->attr
, sym
->name
,
5518 &gfc_new_block
->declared_at
);
5522 gfc_commit_symbols ();
5525 sym
= gfc_new_block
;
5527 /* Mark this as a contained function, so it isn't replaced
5528 by other module functions. */
5529 sym
->attr
.contained
= 1;
5531 /* Set implicit_pure so that it can be reset if any of the
5532 tests for purity fail. This is used for some optimisation
5533 during translation. */
5534 if (!sym
->attr
.pure
)
5535 sym
->attr
.implicit_pure
= 1;
5537 parse_progunit (ST_NONE
);
5539 /* Fix up any sibling functions that refer to this one. */
5540 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
5541 /* Or refer to any of its alternate entry points. */
5542 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
5543 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
5545 gfc_current_ns
->code
= s2
.head
;
5546 gfc_current_ns
= parent_ns
;
5551 /* These statements are associated with the end of the host unit. */
5552 case ST_END_FUNCTION
:
5554 case ST_END_SUBMODULE
:
5555 case ST_END_PROGRAM
:
5556 case ST_END_SUBROUTINE
:
5557 accept_statement (st
);
5558 gfc_current_ns
->code
= s1
.head
;
5562 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
5563 gfc_ascii_statement (st
));
5564 reject_statement ();
5570 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
5571 && st
!= ST_END_MODULE
&& st
!= ST_END_SUBMODULE
5572 && st
!= ST_END_PROGRAM
);
5574 /* The first namespace in the list is guaranteed to not have
5575 anything (worthwhile) in it. */
5576 tmp
= gfc_current_ns
;
5577 gfc_current_ns
= parent_ns
;
5578 if (seen_error
&& tmp
->refs
> 1)
5579 gfc_free_namespace (tmp
);
5581 ns
= gfc_current_ns
->contained
;
5582 gfc_current_ns
->contained
= ns
->sibling
;
5583 gfc_free_namespace (ns
);
5586 if (!contains_statements
)
5587 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
5588 "FUNCTION or SUBROUTINE statement at %L", &old_loc
);
5592 /* The result variable in a MODULE PROCEDURE needs to be created and
5593 its characteristics copied from the interface since it is neither
5594 declared in the procedure declaration nor in the specification
5598 get_modproc_result (void)
5601 if (gfc_state_stack
->previous
5602 && gfc_state_stack
->previous
->state
== COMP_CONTAINS
5603 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
5605 proc
= gfc_current_ns
->proc_name
? gfc_current_ns
->proc_name
: NULL
;
5607 && proc
->attr
.function
5609 && proc
->tlink
->result
5610 && proc
->tlink
->result
!= proc
->tlink
)
5612 gfc_copy_dummy_sym (&proc
->result
, proc
->tlink
->result
, 1);
5613 gfc_set_sym_referenced (proc
->result
);
5614 proc
->result
->attr
.if_source
= IFSRC_DECL
;
5615 gfc_commit_symbol (proc
->result
);
5621 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
5624 parse_progunit (gfc_statement st
)
5630 && gfc_new_block
->abr_modproc_decl
5631 && gfc_new_block
->attr
.function
)
5632 get_modproc_result ();
5634 st
= parse_spec (st
);
5641 /* This is not allowed within BLOCK! */
5642 if (gfc_current_state () != COMP_BLOCK
)
5647 accept_statement (st
);
5654 if (gfc_current_state () == COMP_FUNCTION
)
5655 gfc_check_function_type (gfc_current_ns
);
5660 st
= parse_executable (st
);
5668 /* This is not allowed within BLOCK! */
5669 if (gfc_current_state () != COMP_BLOCK
)
5674 accept_statement (st
);
5681 unexpected_statement (st
);
5682 reject_statement ();
5683 st
= next_statement ();
5689 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
5690 if (p
->state
== COMP_CONTAINS
)
5693 if (gfc_find_state (COMP_MODULE
) == true
5694 || gfc_find_state (COMP_SUBMODULE
) == true)
5699 gfc_error ("CONTAINS statement at %C is already in a contained "
5701 reject_statement ();
5702 st
= next_statement ();
5706 parse_contained (0);
5709 gfc_current_ns
->code
= gfc_state_stack
->head
;
5713 /* Come here to complain about a global symbol already in use as
5717 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
5722 where
= &gfc_current_locus
;
5732 case GSYM_SUBROUTINE
:
5733 name
= "SUBROUTINE";
5738 case GSYM_BLOCK_DATA
:
5739 name
= "BLOCK DATA";
5750 if (sym
->binding_label
)
5751 gfc_error ("Global binding name %qs at %L is already being used "
5752 "as a %s at %L", sym
->binding_label
, where
, name
,
5755 gfc_error ("Global name %qs at %L is already being used as "
5756 "a %s at %L", sym
->name
, where
, name
, &sym
->where
);
5760 if (sym
->binding_label
)
5761 gfc_error ("Global binding name %qs at %L is already being used "
5762 "at %L", sym
->binding_label
, where
, &sym
->where
);
5764 gfc_error ("Global name %qs at %L is already being used at %L",
5765 sym
->name
, where
, &sym
->where
);
5770 /* Parse a block data program unit. */
5773 parse_block_data (void)
5776 static locus blank_locus
;
5777 static int blank_block
=0;
5780 gfc_current_ns
->proc_name
= gfc_new_block
;
5781 gfc_current_ns
->is_block_data
= 1;
5783 if (gfc_new_block
== NULL
)
5786 gfc_error ("Blank BLOCK DATA at %C conflicts with "
5787 "prior BLOCK DATA at %L", &blank_locus
);
5791 blank_locus
= gfc_current_locus
;
5796 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5798 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
5799 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5802 s
->type
= GSYM_BLOCK_DATA
;
5803 s
->where
= gfc_new_block
->declared_at
;
5808 st
= parse_spec (ST_NONE
);
5810 while (st
!= ST_END_BLOCK_DATA
)
5812 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
5813 gfc_ascii_statement (st
));
5814 reject_statement ();
5815 st
= next_statement ();
5820 /* Following the association of the ancestor (sub)module symbols, they
5821 must be set host rather than use associated and all must be public.
5822 They are flagged up by 'used_in_submodule' so that they can be set
5823 DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
5824 linker chokes on multiple symbol definitions. */
5827 set_syms_host_assoc (gfc_symbol
*sym
)
5830 const char dot
[2] = ".";
5831 char parent1
[GFC_MAX_SYMBOL_LEN
+ 1];
5832 char parent2
[GFC_MAX_SYMBOL_LEN
+ 1];
5837 if (sym
->attr
.module_procedure
)
5838 sym
->attr
.external
= 0;
5840 sym
->attr
.use_assoc
= 0;
5841 sym
->attr
.host_assoc
= 1;
5842 sym
->attr
.used_in_submodule
=1;
5844 if (sym
->attr
.flavor
== FL_DERIVED
)
5846 /* Derived types with PRIVATE components that are declared in
5847 modules other than the parent module must not be changed to be
5848 PUBLIC. The 'use-assoc' attribute must be reset so that the
5849 test in symbol.c(gfc_find_component) works correctly. This is
5850 not necessary for PRIVATE symbols since they are not read from
5852 memset(parent1
, '\0', sizeof(parent1
));
5853 memset(parent2
, '\0', sizeof(parent2
));
5854 strcpy (parent1
, gfc_new_block
->name
);
5855 strcpy (parent2
, sym
->module
);
5856 if (strcmp (strtok (parent1
, dot
), strtok (parent2
, dot
)) == 0)
5858 for (c
= sym
->components
; c
; c
= c
->next
)
5859 c
->attr
.access
= ACCESS_PUBLIC
;
5863 sym
->attr
.use_assoc
= 1;
5864 sym
->attr
.host_assoc
= 0;
5869 /* Parse a module subprogram. */
5878 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5879 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
5880 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5883 s
->type
= GSYM_MODULE
;
5884 s
->where
= gfc_new_block
->declared_at
;
5888 /* Something is nulling the module_list after this point. This is good
5889 since it allows us to 'USE' the parent modules that the submodule
5890 inherits and to set (most) of the symbols as host associated. */
5891 if (gfc_current_state () == COMP_SUBMODULE
)
5894 gfc_traverse_ns (gfc_current_ns
, set_syms_host_assoc
);
5897 st
= parse_spec (ST_NONE
);
5907 parse_contained (1);
5911 case ST_END_SUBMODULE
:
5912 accept_statement (st
);
5916 gfc_error ("Unexpected %s statement in MODULE at %C",
5917 gfc_ascii_statement (st
));
5920 reject_statement ();
5921 st
= next_statement ();
5925 /* Make sure not to free the namespace twice on error. */
5927 s
->ns
= gfc_current_ns
;
5931 /* Add a procedure name to the global symbol table. */
5934 add_global_procedure (bool sub
)
5938 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5939 name is a global identifier. */
5940 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5942 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5945 || (s
->type
!= GSYM_UNKNOWN
5946 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5948 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5949 /* Silence follow-up errors. */
5950 gfc_new_block
->binding_label
= NULL
;
5954 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5955 s
->sym_name
= gfc_new_block
->name
;
5956 s
->where
= gfc_new_block
->declared_at
;
5958 s
->ns
= gfc_current_ns
;
5962 /* Don't add the symbol multiple times. */
5963 if (gfc_new_block
->binding_label
5964 && (!gfc_notification_std (GFC_STD_F2008
)
5965 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
5967 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
);
5970 || (s
->type
!= GSYM_UNKNOWN
5971 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5973 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5974 /* Silence follow-up errors. */
5975 gfc_new_block
->binding_label
= NULL
;
5979 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5980 s
->sym_name
= gfc_new_block
->name
;
5981 s
->binding_label
= gfc_new_block
->binding_label
;
5982 s
->where
= gfc_new_block
->declared_at
;
5984 s
->ns
= gfc_current_ns
;
5990 /* Add a program to the global symbol table. */
5993 add_global_program (void)
5997 if (gfc_new_block
== NULL
)
5999 s
= gfc_get_gsymbol (gfc_new_block
->name
);
6001 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
6002 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6005 s
->type
= GSYM_PROGRAM
;
6006 s
->where
= gfc_new_block
->declared_at
;
6008 s
->ns
= gfc_current_ns
;
6013 /* Resolve all the program units. */
6015 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
6017 gfc_free_dt_list ();
6018 gfc_current_ns
= gfc_global_ns_list
;
6019 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6021 if (gfc_current_ns
->proc_name
6022 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6023 continue; /* Already resolved. */
6025 if (gfc_current_ns
->proc_name
)
6026 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6027 gfc_resolve (gfc_current_ns
);
6028 gfc_current_ns
->derived_types
= gfc_derived_types
;
6029 gfc_derived_types
= NULL
;
6035 clean_up_modules (gfc_gsymbol
*gsym
)
6040 clean_up_modules (gsym
->left
);
6041 clean_up_modules (gsym
->right
);
6043 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
6046 gfc_current_ns
= gsym
->ns
;
6047 gfc_derived_types
= gfc_current_ns
->derived_types
;
6054 /* Translate all the program units. This could be in a different order
6055 to resolution if there are forward references in the file. */
6057 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
6061 gfc_current_ns
= gfc_global_ns_list
;
6062 gfc_get_errors (NULL
, &errors
);
6064 /* We first translate all modules to make sure that later parts
6065 of the program can use the decl. Then we translate the nonmodules. */
6067 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6069 if (!gfc_current_ns
->proc_name
6070 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6073 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6074 gfc_derived_types
= gfc_current_ns
->derived_types
;
6075 gfc_generate_module_code (gfc_current_ns
);
6076 gfc_current_ns
->translated
= 1;
6079 gfc_current_ns
= gfc_global_ns_list
;
6080 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6082 if (gfc_current_ns
->proc_name
6083 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6086 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6087 gfc_derived_types
= gfc_current_ns
->derived_types
;
6088 gfc_generate_code (gfc_current_ns
);
6089 gfc_current_ns
->translated
= 1;
6092 /* Clean up all the namespaces after translation. */
6093 gfc_current_ns
= gfc_global_ns_list
;
6094 for (;gfc_current_ns
;)
6098 if (gfc_current_ns
->proc_name
6099 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6101 gfc_current_ns
= gfc_current_ns
->sibling
;
6105 ns
= gfc_current_ns
->sibling
;
6106 gfc_derived_types
= gfc_current_ns
->derived_types
;
6108 gfc_current_ns
= ns
;
6111 clean_up_modules (gfc_gsym_root
);
6115 /* Top level parser. */
6118 gfc_parse_file (void)
6120 int seen_program
, errors_before
, errors
;
6121 gfc_state_data top
, s
;
6124 gfc_namespace
*next
;
6126 gfc_start_source_files ();
6128 top
.state
= COMP_NONE
;
6130 top
.previous
= NULL
;
6131 top
.head
= top
.tail
= NULL
;
6132 top
.do_variable
= NULL
;
6134 gfc_state_stack
= &top
;
6136 gfc_clear_new_st ();
6138 gfc_statement_label
= NULL
;
6140 if (setjmp (eof_buf
))
6141 return false; /* Come here on unexpected EOF */
6143 /* Prepare the global namespace that will contain the
6145 gfc_global_ns_list
= next
= NULL
;
6150 /* Exit early for empty files. */
6154 in_specification_block
= true;
6157 st
= next_statement ();
6166 goto duplicate_main
;
6168 prog_locus
= gfc_current_locus
;
6170 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
6171 main_program_symbol (gfc_current_ns
, gfc_new_block
->name
);
6172 accept_statement (st
);
6173 add_global_program ();
6174 parse_progunit (ST_NONE
);
6178 add_global_procedure (true);
6179 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
6180 accept_statement (st
);
6181 parse_progunit (ST_NONE
);
6185 add_global_procedure (false);
6186 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
6187 accept_statement (st
);
6188 parse_progunit (ST_NONE
);
6192 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
6193 accept_statement (st
);
6194 parse_block_data ();
6198 push_state (&s
, COMP_MODULE
, gfc_new_block
);
6199 accept_statement (st
);
6201 gfc_get_errors (NULL
, &errors_before
);
6206 push_state (&s
, COMP_SUBMODULE
, gfc_new_block
);
6207 accept_statement (st
);
6209 gfc_get_errors (NULL
, &errors_before
);
6213 /* Anything else starts a nameless main program block. */
6216 goto duplicate_main
;
6218 prog_locus
= gfc_current_locus
;
6220 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
6221 main_program_symbol (gfc_current_ns
, "MAIN__");
6222 parse_progunit (st
);
6226 /* Handle the non-program units. */
6227 gfc_current_ns
->code
= s
.head
;
6229 gfc_resolve (gfc_current_ns
);
6231 /* Dump the parse tree if requested. */
6232 if (flag_dump_fortran_original
)
6233 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6235 if (flag_c_prototypes
)
6236 gfc_dump_c_prototypes (gfc_current_ns
, stdout
);
6238 gfc_get_errors (NULL
, &errors
);
6239 if (s
.state
== COMP_MODULE
|| s
.state
== COMP_SUBMODULE
)
6241 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
6242 gfc_current_ns
->derived_types
= gfc_derived_types
;
6243 gfc_derived_types
= NULL
;
6249 gfc_generate_code (gfc_current_ns
);
6257 /* The main program and non-contained procedures are put
6258 in the global namespace list, so that they can be processed
6259 later and all their interfaces resolved. */
6260 gfc_current_ns
->code
= s
.head
;
6263 for (; next
->sibling
; next
= next
->sibling
)
6265 next
->sibling
= gfc_current_ns
;
6268 gfc_global_ns_list
= gfc_current_ns
;
6270 next
= gfc_current_ns
;
6276 /* Do the resolution. */
6277 resolve_all_program_units (gfc_global_ns_list
);
6279 /* Do the parse tree dump. */
6280 gfc_current_ns
= flag_dump_fortran_original
? gfc_global_ns_list
: NULL
;
6282 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6283 if (!gfc_current_ns
->proc_name
6284 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6286 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6287 fputs ("------------------------------------------\n\n", stdout
);
6290 /* Do the translation. */
6291 translate_all_program_units (gfc_global_ns_list
);
6293 gfc_end_source_files ();
6297 /* If we see a duplicate main program, shut down. If the second
6298 instance is an implied main program, i.e. data decls or executable
6299 statements, we're in for lots of errors. */
6300 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
6301 reject_statement ();
6306 /* Return true if this state data represents an OpenACC region. */
6308 is_oacc (gfc_state_data
*sd
)
6310 switch (sd
->construct
->op
)
6312 case EXEC_OACC_PARALLEL_LOOP
:
6313 case EXEC_OACC_PARALLEL
:
6314 case EXEC_OACC_KERNELS_LOOP
:
6315 case EXEC_OACC_KERNELS
:
6316 case EXEC_OACC_DATA
:
6317 case EXEC_OACC_HOST_DATA
:
6318 case EXEC_OACC_LOOP
:
6319 case EXEC_OACC_UPDATE
:
6320 case EXEC_OACC_WAIT
:
6321 case EXEC_OACC_CACHE
:
6322 case EXEC_OACC_ENTER_DATA
:
6323 case EXEC_OACC_EXIT_DATA
:
6324 case EXEC_OACC_ATOMIC
:
6325 case EXEC_OACC_ROUTINE
: