2 Copyright (C) 2000-2018 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
);
1066 match ("unroll", gfc_match_gcc_unroll
, ST_NONE
);
1068 /* All else has failed, so give up. See if any of the matchers has
1069 stored an error message of some sort. */
1071 if (!gfc_error_check ())
1072 gfc_error_now ("Unclassifiable GCC directive at %C");
1074 reject_statement ();
1076 gfc_error_recovery ();
1083 /* Assert next length characters to be equal to token in free form. */
1086 verify_token_free (const char* token
, int length
, bool last_was_use_stmt
)
1091 c
= gfc_next_ascii_char ();
1092 for (i
= 0; i
< length
; i
++, c
= gfc_next_ascii_char ())
1093 gcc_assert (c
== token
[i
]);
1095 gcc_assert (gfc_is_whitespace(c
));
1096 gfc_gobble_whitespace ();
1097 if (last_was_use_stmt
)
1101 /* Get the next statement in free form source. */
1103 static gfc_statement
1110 at_bol
= gfc_at_bol ();
1111 gfc_gobble_whitespace ();
1113 c
= gfc_peek_ascii_char ();
1119 /* Found a statement label? */
1120 m
= gfc_match_st_label (&gfc_statement_label
);
1122 d
= gfc_peek_ascii_char ();
1123 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
1125 gfc_match_small_literal_int (&i
, &cnt
);
1128 gfc_error_now ("Too many digits in statement label at %C");
1131 gfc_error_now ("Zero is not a valid statement label at %C");
1134 c
= gfc_next_ascii_char ();
1137 if (!gfc_is_whitespace (c
))
1138 gfc_error_now ("Non-numeric character in statement label at %C");
1144 label_locus
= gfc_current_locus
;
1146 gfc_gobble_whitespace ();
1148 if (at_bol
&& gfc_peek_ascii_char () == ';')
1150 gfc_error_now ("Semicolon at %C needs to be preceded by "
1152 gfc_next_ascii_char (); /* Eat up the semicolon. */
1156 if (gfc_match_eos () == MATCH_YES
)
1157 gfc_error_now ("Statement label without statement at %L",
1163 /* Comments have already been skipped by the time we get here,
1164 except for GCC attributes and OpenMP/OpenACC directives. */
1166 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
1167 c
= gfc_peek_ascii_char ();
1173 c
= gfc_next_ascii_char ();
1174 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
1175 gcc_assert (c
== "gcc$"[i
]);
1177 gfc_gobble_whitespace ();
1178 return decode_gcc_attribute ();
1183 /* Since both OpenMP and OpenACC directives starts with
1184 !$ character sequence, we must check all flags combinations */
1185 if ((flag_openmp
|| flag_openmp_simd
)
1188 verify_token_free ("$omp", 4, last_was_use_stmt
);
1189 return decode_omp_directive ();
1191 else if ((flag_openmp
|| flag_openmp_simd
)
1194 gfc_next_ascii_char (); /* Eat up dollar character */
1195 c
= gfc_peek_ascii_char ();
1199 verify_token_free ("omp", 3, last_was_use_stmt
);
1200 return decode_omp_directive ();
1204 verify_token_free ("acc", 3, last_was_use_stmt
);
1205 return decode_oacc_directive ();
1208 else if (flag_openacc
)
1210 verify_token_free ("$acc", 4, last_was_use_stmt
);
1211 return decode_oacc_directive ();
1217 if (at_bol
&& c
== ';')
1219 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1220 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1222 gfc_next_ascii_char (); /* Eat up the semicolon. */
1226 return decode_statement ();
1229 /* Assert next length characters to be equal to token in fixed form. */
1232 verify_token_fixed (const char *token
, int length
, bool last_was_use_stmt
)
1235 char c
= gfc_next_char_literal (NONSTRING
);
1237 for (i
= 0; i
< length
; i
++, c
= gfc_next_char_literal (NONSTRING
))
1238 gcc_assert ((char) gfc_wide_tolower (c
) == token
[i
]);
1240 if (c
!= ' ' && c
!= '0')
1242 gfc_buffer_error (false);
1243 gfc_error ("Bad continuation line at %C");
1246 if (last_was_use_stmt
)
1252 /* Get the next statement in fixed-form source. */
1254 static gfc_statement
1257 int label
, digit_flag
, i
;
1262 return decode_statement ();
1264 /* Skip past the current label field, parsing a statement label if
1265 one is there. This is a weird number parser, since the number is
1266 contained within five columns and can have any kind of embedded
1267 spaces. We also check for characters that make the rest of the
1273 for (i
= 0; i
< 5; i
++)
1275 c
= gfc_next_char_literal (NONSTRING
);
1292 label
= label
* 10 + ((unsigned char) c
- '0');
1293 label_locus
= gfc_current_locus
;
1297 /* Comments have already been skipped by the time we get
1298 here, except for GCC attributes and OpenMP directives. */
1301 c
= gfc_next_char_literal (NONSTRING
);
1303 if (TOLOWER (c
) == 'g')
1305 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
1306 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
1308 return decode_gcc_attribute ();
1312 if ((flag_openmp
|| flag_openmp_simd
)
1315 if (!verify_token_fixed ("omp", 3, last_was_use_stmt
))
1317 return decode_omp_directive ();
1319 else if ((flag_openmp
|| flag_openmp_simd
)
1322 c
= gfc_next_char_literal(NONSTRING
);
1323 if (c
== 'o' || c
== 'O')
1325 if (!verify_token_fixed ("mp", 2, last_was_use_stmt
))
1327 return decode_omp_directive ();
1329 else if (c
== 'a' || c
== 'A')
1331 if (!verify_token_fixed ("cc", 2, last_was_use_stmt
))
1333 return decode_oacc_directive ();
1336 else if (flag_openacc
)
1338 if (!verify_token_fixed ("acc", 3, last_was_use_stmt
))
1340 return decode_oacc_directive ();
1345 /* Comments have already been skipped by the time we get
1346 here so don't bother checking for them. */
1349 gfc_buffer_error (false);
1350 gfc_error ("Non-numeric character in statement label at %C");
1358 gfc_warning_now (0, "Zero is not a valid statement label at %C");
1361 /* We've found a valid statement label. */
1362 gfc_statement_label
= gfc_get_st_label (label
);
1366 /* Since this line starts a statement, it cannot be a continuation
1367 of a previous statement. If we see something here besides a
1368 space or zero, it must be a bad continuation line. */
1370 c
= gfc_next_char_literal (NONSTRING
);
1374 if (c
!= ' ' && c
!= '0')
1376 gfc_buffer_error (false);
1377 gfc_error ("Bad continuation line at %C");
1381 /* Now that we've taken care of the statement label columns, we have
1382 to make sure that the first nonblank character is not a '!'. If
1383 it is, the rest of the line is a comment. */
1387 loc
= gfc_current_locus
;
1388 c
= gfc_next_char_literal (NONSTRING
);
1390 while (gfc_is_whitespace (c
));
1394 gfc_current_locus
= loc
;
1399 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1400 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1401 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1406 if (gfc_match_eos () == MATCH_YES
)
1409 /* At this point, we've got a nonblank statement to parse. */
1410 return decode_statement ();
1414 gfc_error_now ("Statement label without statement at %L", &label_locus
);
1416 gfc_current_locus
.lb
->truncated
= 0;
1417 gfc_advance_line ();
1422 /* Return the next non-ST_NONE statement to the caller. We also worry
1423 about including files and the ends of include files at this stage. */
1425 static gfc_statement
1426 next_statement (void)
1431 gfc_enforce_clean_symbol_state ();
1433 gfc_new_block
= NULL
;
1435 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1436 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
1439 gfc_statement_label
= NULL
;
1440 gfc_buffer_error (true);
1443 gfc_advance_line ();
1445 gfc_skip_comments ();
1453 if (gfc_define_undef_line ())
1456 old_locus
= gfc_current_locus
;
1458 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1464 gfc_buffer_error (false);
1466 if (st
== ST_GET_FCN_CHARACTERISTICS
)
1468 if (gfc_statement_label
!= NULL
)
1470 gfc_free_st_label (gfc_statement_label
);
1471 gfc_statement_label
= NULL
;
1473 gfc_current_locus
= old_locus
;
1477 check_statement_label (st
);
1483 /****************************** Parser ***********************************/
1485 /* The parser subroutines are of type 'try' that fail if the file ends
1488 /* Macros that expand to case-labels for various classes of
1489 statements. Start with executable statements that directly do
1492 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1493 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1494 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1495 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1496 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1497 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1498 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1499 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1500 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1501 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
1502 case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
1503 case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: \
1504 case ST_ERROR_STOP: case ST_SYNC_ALL: \
1505 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1506 case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
1507 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1508 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1510 /* Statements that mark other executable statements. */
1512 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1513 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1514 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1515 case ST_OMP_PARALLEL: \
1516 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1517 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
1518 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1519 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1520 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1521 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1522 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1523 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1524 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1525 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1526 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1527 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1528 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1529 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1530 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1531 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1532 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \
1533 case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \
1534 case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
1536 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1537 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
1538 case ST_OACC_KERNELS_LOOP: case ST_OACC_ATOMIC
1540 /* Declaration statements */
1542 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1543 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1544 case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE: case ST_OACC_ROUTINE: \
1545 case ST_OACC_DECLARE
1547 /* OpenMP declaration statements. */
1549 #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
1550 case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION
1552 /* Block end statements. Errors associated with interchanging these
1553 are detected in gfc_match_end(). */
1555 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1556 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1557 case ST_END_BLOCK: case ST_END_ASSOCIATE
1560 /* Push a new state onto the stack. */
1563 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1565 p
->state
= new_state
;
1566 p
->previous
= gfc_state_stack
;
1568 p
->head
= p
->tail
= NULL
;
1569 p
->do_variable
= NULL
;
1570 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1571 p
->ext
.oacc_declare_clauses
= NULL
;
1573 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1574 construct statement was accepted right before pushing the state. Thus,
1575 the construct's gfc_code is available as tail of the parent state. */
1576 gcc_assert (gfc_state_stack
);
1577 p
->construct
= gfc_state_stack
->tail
;
1579 gfc_state_stack
= p
;
1583 /* Pop the current state. */
1587 gfc_state_stack
= gfc_state_stack
->previous
;
1591 /* Try to find the given state in the state stack. */
1594 gfc_find_state (gfc_compile_state state
)
1598 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1599 if (p
->state
== state
)
1602 return (p
== NULL
) ? false : true;
1606 /* Starts a new level in the statement list. */
1609 new_level (gfc_code
*q
)
1613 p
= q
->block
= gfc_get_code (EXEC_NOP
);
1615 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1621 /* Add the current new_st code structure and adds it to the current
1622 program unit. As a side-effect, it zeroes the new_st. */
1625 add_statement (void)
1629 p
= XCNEW (gfc_code
);
1632 p
->loc
= gfc_current_locus
;
1634 if (gfc_state_stack
->head
== NULL
)
1635 gfc_state_stack
->head
= p
;
1637 gfc_state_stack
->tail
->next
= p
;
1639 while (p
->next
!= NULL
)
1642 gfc_state_stack
->tail
= p
;
1644 gfc_clear_new_st ();
1650 /* Frees everything associated with the current statement. */
1653 undo_new_statement (void)
1655 gfc_free_statements (new_st
.block
);
1656 gfc_free_statements (new_st
.next
);
1657 gfc_free_statement (&new_st
);
1658 gfc_clear_new_st ();
1662 /* If the current statement has a statement label, make sure that it
1663 is allowed to, or should have one. */
1666 check_statement_label (gfc_statement st
)
1670 if (gfc_statement_label
== NULL
)
1672 if (st
== ST_FORMAT
)
1673 gfc_error ("FORMAT statement at %L does not have a statement label",
1680 case ST_END_PROGRAM
:
1681 case ST_END_FUNCTION
:
1682 case ST_END_SUBROUTINE
:
1686 case ST_END_CRITICAL
:
1688 case ST_END_ASSOCIATE
:
1691 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
1692 type
= ST_LABEL_DO_TARGET
;
1694 type
= ST_LABEL_TARGET
;
1698 type
= ST_LABEL_FORMAT
;
1701 /* Statement labels are not restricted from appearing on a
1702 particular line. However, there are plenty of situations
1703 where the resulting label can't be referenced. */
1706 type
= ST_LABEL_BAD_TARGET
;
1710 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1712 new_st
.here
= gfc_statement_label
;
1716 /* Figures out what the enclosing program unit is. This will be a
1717 function, subroutine, program, block data or module. */
1720 gfc_enclosing_unit (gfc_compile_state
* result
)
1724 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1725 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1726 || p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
1727 || p
->state
== COMP_BLOCK_DATA
|| p
->state
== COMP_PROGRAM
)
1736 *result
= COMP_PROGRAM
;
1741 /* Translate a statement enum to a string. */
1744 gfc_ascii_statement (gfc_statement st
)
1750 case ST_ARITHMETIC_IF
:
1751 p
= _("arithmetic IF");
1760 p
= _("attribute declaration");
1796 p
= _("data declaration");
1810 case ST_STRUCTURE_DECL
:
1813 case ST_DERIVED_DECL
:
1814 p
= _("derived type declaration");
1837 case ST_END_ASSOCIATE
:
1838 p
= "END ASSOCIATE";
1843 case ST_END_BLOCK_DATA
:
1844 p
= "END BLOCK DATA";
1846 case ST_END_CRITICAL
:
1858 case ST_END_FUNCTION
:
1864 case ST_END_INTERFACE
:
1865 p
= "END INTERFACE";
1870 case ST_END_SUBMODULE
:
1871 p
= "END SUBMODULE";
1873 case ST_END_PROGRAM
:
1879 case ST_END_SUBROUTINE
:
1880 p
= "END SUBROUTINE";
1885 case ST_END_STRUCTURE
:
1886 p
= "END STRUCTURE";
1900 case ST_EQUIVALENCE
:
1912 case ST_FORALL_BLOCK
: /* Fall through */
1934 case ST_IMPLICIT_NONE
:
1935 p
= "IMPLICIT NONE";
1937 case ST_IMPLIED_ENDDO
:
1938 p
= _("implied END DO");
1970 case ST_MODULE_PROC
:
1971 p
= "MODULE PROCEDURE";
2003 case ST_SYNC_IMAGES
:
2006 case ST_SYNC_MEMORY
:
2021 case ST_WHERE_BLOCK
: /* Fall through */
2032 p
= _("assignment");
2034 case ST_POINTER_ASSIGNMENT
:
2035 p
= _("pointer assignment");
2037 case ST_SELECT_CASE
:
2040 case ST_SELECT_TYPE
:
2055 case ST_STATEMENT_FUNCTION
:
2056 p
= "STATEMENT FUNCTION";
2058 case ST_LABEL_ASSIGNMENT
:
2059 p
= "LABEL ASSIGNMENT";
2062 p
= "ENUM DEFINITION";
2065 p
= "ENUMERATOR DEFINITION";
2070 case ST_OACC_PARALLEL_LOOP
:
2071 p
= "!$ACC PARALLEL LOOP";
2073 case ST_OACC_END_PARALLEL_LOOP
:
2074 p
= "!$ACC END PARALLEL LOOP";
2076 case ST_OACC_PARALLEL
:
2077 p
= "!$ACC PARALLEL";
2079 case ST_OACC_END_PARALLEL
:
2080 p
= "!$ACC END PARALLEL";
2082 case ST_OACC_KERNELS
:
2083 p
= "!$ACC KERNELS";
2085 case ST_OACC_END_KERNELS
:
2086 p
= "!$ACC END KERNELS";
2088 case ST_OACC_KERNELS_LOOP
:
2089 p
= "!$ACC KERNELS LOOP";
2091 case ST_OACC_END_KERNELS_LOOP
:
2092 p
= "!$ACC END KERNELS LOOP";
2097 case ST_OACC_END_DATA
:
2098 p
= "!$ACC END DATA";
2100 case ST_OACC_HOST_DATA
:
2101 p
= "!$ACC HOST_DATA";
2103 case ST_OACC_END_HOST_DATA
:
2104 p
= "!$ACC END HOST_DATA";
2109 case ST_OACC_END_LOOP
:
2110 p
= "!$ACC END LOOP";
2112 case ST_OACC_DECLARE
:
2113 p
= "!$ACC DECLARE";
2115 case ST_OACC_UPDATE
:
2124 case ST_OACC_ENTER_DATA
:
2125 p
= "!$ACC ENTER DATA";
2127 case ST_OACC_EXIT_DATA
:
2128 p
= "!$ACC EXIT DATA";
2130 case ST_OACC_ROUTINE
:
2131 p
= "!$ACC ROUTINE";
2133 case ST_OACC_ATOMIC
:
2136 case ST_OACC_END_ATOMIC
:
2137 p
= "!$ACC END ATOMIC";
2142 case ST_OMP_BARRIER
:
2143 p
= "!$OMP BARRIER";
2148 case ST_OMP_CANCELLATION_POINT
:
2149 p
= "!$OMP CANCELLATION POINT";
2151 case ST_OMP_CRITICAL
:
2152 p
= "!$OMP CRITICAL";
2154 case ST_OMP_DECLARE_REDUCTION
:
2155 p
= "!$OMP DECLARE REDUCTION";
2157 case ST_OMP_DECLARE_SIMD
:
2158 p
= "!$OMP DECLARE SIMD";
2160 case ST_OMP_DECLARE_TARGET
:
2161 p
= "!$OMP DECLARE TARGET";
2163 case ST_OMP_DISTRIBUTE
:
2164 p
= "!$OMP DISTRIBUTE";
2166 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
2167 p
= "!$OMP DISTRIBUTE PARALLEL DO";
2169 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2170 p
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
2172 case ST_OMP_DISTRIBUTE_SIMD
:
2173 p
= "!$OMP DISTRIBUTE SIMD";
2178 case ST_OMP_DO_SIMD
:
2179 p
= "!$OMP DO SIMD";
2181 case ST_OMP_END_ATOMIC
:
2182 p
= "!$OMP END ATOMIC";
2184 case ST_OMP_END_CRITICAL
:
2185 p
= "!$OMP END CRITICAL";
2187 case ST_OMP_END_DISTRIBUTE
:
2188 p
= "!$OMP END DISTRIBUTE";
2190 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO
:
2191 p
= "!$OMP END DISTRIBUTE PARALLEL DO";
2193 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
:
2194 p
= "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
2196 case ST_OMP_END_DISTRIBUTE_SIMD
:
2197 p
= "!$OMP END DISTRIBUTE SIMD";
2202 case ST_OMP_END_DO_SIMD
:
2203 p
= "!$OMP END DO SIMD";
2205 case ST_OMP_END_SIMD
:
2206 p
= "!$OMP END SIMD";
2208 case ST_OMP_END_MASTER
:
2209 p
= "!$OMP END MASTER";
2211 case ST_OMP_END_ORDERED
:
2212 p
= "!$OMP END ORDERED";
2214 case ST_OMP_END_PARALLEL
:
2215 p
= "!$OMP END PARALLEL";
2217 case ST_OMP_END_PARALLEL_DO
:
2218 p
= "!$OMP END PARALLEL DO";
2220 case ST_OMP_END_PARALLEL_DO_SIMD
:
2221 p
= "!$OMP END PARALLEL DO SIMD";
2223 case ST_OMP_END_PARALLEL_SECTIONS
:
2224 p
= "!$OMP END PARALLEL SECTIONS";
2226 case ST_OMP_END_PARALLEL_WORKSHARE
:
2227 p
= "!$OMP END PARALLEL WORKSHARE";
2229 case ST_OMP_END_SECTIONS
:
2230 p
= "!$OMP END SECTIONS";
2232 case ST_OMP_END_SINGLE
:
2233 p
= "!$OMP END SINGLE";
2235 case ST_OMP_END_TASK
:
2236 p
= "!$OMP END TASK";
2238 case ST_OMP_END_TARGET
:
2239 p
= "!$OMP END TARGET";
2241 case ST_OMP_END_TARGET_DATA
:
2242 p
= "!$OMP END TARGET DATA";
2244 case ST_OMP_END_TARGET_PARALLEL
:
2245 p
= "!$OMP END TARGET PARALLEL";
2247 case ST_OMP_END_TARGET_PARALLEL_DO
:
2248 p
= "!$OMP END TARGET PARALLEL DO";
2250 case ST_OMP_END_TARGET_PARALLEL_DO_SIMD
:
2251 p
= "!$OMP END TARGET PARALLEL DO SIMD";
2253 case ST_OMP_END_TARGET_SIMD
:
2254 p
= "!$OMP END TARGET SIMD";
2256 case ST_OMP_END_TARGET_TEAMS
:
2257 p
= "!$OMP END TARGET TEAMS";
2259 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
:
2260 p
= "!$OMP END TARGET TEAMS DISTRIBUTE";
2262 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2263 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2265 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2266 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2268 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2269 p
= "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2271 case ST_OMP_END_TASKGROUP
:
2272 p
= "!$OMP END TASKGROUP";
2274 case ST_OMP_END_TASKLOOP
:
2275 p
= "!$OMP END TASKLOOP";
2277 case ST_OMP_END_TASKLOOP_SIMD
:
2278 p
= "!$OMP END TASKLOOP SIMD";
2280 case ST_OMP_END_TEAMS
:
2281 p
= "!$OMP END TEAMS";
2283 case ST_OMP_END_TEAMS_DISTRIBUTE
:
2284 p
= "!$OMP END TEAMS DISTRIBUTE";
2286 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2287 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2289 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2290 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2292 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
:
2293 p
= "!$OMP END TEAMS DISTRIBUTE SIMD";
2295 case ST_OMP_END_WORKSHARE
:
2296 p
= "!$OMP END WORKSHARE";
2304 case ST_OMP_ORDERED
:
2305 case ST_OMP_ORDERED_DEPEND
:
2306 p
= "!$OMP ORDERED";
2308 case ST_OMP_PARALLEL
:
2309 p
= "!$OMP PARALLEL";
2311 case ST_OMP_PARALLEL_DO
:
2312 p
= "!$OMP PARALLEL DO";
2314 case ST_OMP_PARALLEL_DO_SIMD
:
2315 p
= "!$OMP PARALLEL DO SIMD";
2317 case ST_OMP_PARALLEL_SECTIONS
:
2318 p
= "!$OMP PARALLEL SECTIONS";
2320 case ST_OMP_PARALLEL_WORKSHARE
:
2321 p
= "!$OMP PARALLEL WORKSHARE";
2323 case ST_OMP_SECTIONS
:
2324 p
= "!$OMP SECTIONS";
2326 case ST_OMP_SECTION
:
2327 p
= "!$OMP SECTION";
2338 case ST_OMP_TARGET_DATA
:
2339 p
= "!$OMP TARGET DATA";
2341 case ST_OMP_TARGET_ENTER_DATA
:
2342 p
= "!$OMP TARGET ENTER DATA";
2344 case ST_OMP_TARGET_EXIT_DATA
:
2345 p
= "!$OMP TARGET EXIT DATA";
2347 case ST_OMP_TARGET_PARALLEL
:
2348 p
= "!$OMP TARGET PARALLEL";
2350 case ST_OMP_TARGET_PARALLEL_DO
:
2351 p
= "!$OMP TARGET PARALLEL DO";
2353 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
2354 p
= "!$OMP TARGET PARALLEL DO SIMD";
2356 case ST_OMP_TARGET_SIMD
:
2357 p
= "!$OMP TARGET SIMD";
2359 case ST_OMP_TARGET_TEAMS
:
2360 p
= "!$OMP TARGET TEAMS";
2362 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
2363 p
= "!$OMP TARGET TEAMS DISTRIBUTE";
2365 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2366 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2368 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2369 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2371 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2372 p
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2374 case ST_OMP_TARGET_UPDATE
:
2375 p
= "!$OMP TARGET UPDATE";
2380 case ST_OMP_TASKGROUP
:
2381 p
= "!$OMP TASKGROUP";
2383 case ST_OMP_TASKLOOP
:
2384 p
= "!$OMP TASKLOOP";
2386 case ST_OMP_TASKLOOP_SIMD
:
2387 p
= "!$OMP TASKLOOP SIMD";
2389 case ST_OMP_TASKWAIT
:
2390 p
= "!$OMP TASKWAIT";
2392 case ST_OMP_TASKYIELD
:
2393 p
= "!$OMP TASKYIELD";
2398 case ST_OMP_TEAMS_DISTRIBUTE
:
2399 p
= "!$OMP TEAMS DISTRIBUTE";
2401 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2402 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2404 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2405 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2407 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
2408 p
= "!$OMP TEAMS DISTRIBUTE SIMD";
2410 case ST_OMP_THREADPRIVATE
:
2411 p
= "!$OMP THREADPRIVATE";
2413 case ST_OMP_WORKSHARE
:
2414 p
= "!$OMP WORKSHARE";
2417 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2424 /* Create a symbol for the main program and assign it to ns->proc_name. */
2427 main_program_symbol (gfc_namespace
*ns
, const char *name
)
2429 gfc_symbol
*main_program
;
2430 symbol_attribute attr
;
2432 gfc_get_symbol (name
, ns
, &main_program
);
2433 gfc_clear_attr (&attr
);
2434 attr
.flavor
= FL_PROGRAM
;
2435 attr
.proc
= PROC_UNKNOWN
;
2436 attr
.subroutine
= 1;
2437 attr
.access
= ACCESS_PUBLIC
;
2438 attr
.is_main_program
= 1;
2439 main_program
->attr
= attr
;
2440 main_program
->declared_at
= gfc_current_locus
;
2441 ns
->proc_name
= main_program
;
2442 gfc_commit_symbols ();
2446 /* Do whatever is necessary to accept the last statement. */
2449 accept_statement (gfc_statement st
)
2453 case ST_IMPLICIT_NONE
:
2461 gfc_current_ns
->proc_name
= gfc_new_block
;
2464 /* If the statement is the end of a block, lay down a special code
2465 that allows a branch to the end of the block from within the
2466 construct. IF and SELECT are treated differently from DO
2467 (where EXEC_NOP is added inside the loop) for two
2469 1. END DO has a meaning in the sense that after a GOTO to
2470 it, the loop counter must be increased.
2471 2. IF blocks and SELECT blocks can consist of multiple
2472 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
2473 Putting the label before the END IF would make the jump
2474 from, say, the ELSE IF block to the END IF illegal. */
2478 case ST_END_CRITICAL
:
2479 if (gfc_statement_label
!= NULL
)
2481 new_st
.op
= EXEC_END_NESTED_BLOCK
;
2486 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
2487 one parallel block. Thus, we add the special code to the nested block
2488 itself, instead of the parent one. */
2490 case ST_END_ASSOCIATE
:
2491 if (gfc_statement_label
!= NULL
)
2493 new_st
.op
= EXEC_END_BLOCK
;
2498 /* The end-of-program unit statements do not get the special
2499 marker and require a statement of some sort if they are a
2502 case ST_END_PROGRAM
:
2503 case ST_END_FUNCTION
:
2504 case ST_END_SUBROUTINE
:
2505 if (gfc_statement_label
!= NULL
)
2507 new_st
.op
= EXEC_RETURN
;
2512 new_st
.op
= EXEC_END_PROCEDURE
;
2528 gfc_commit_symbols ();
2529 gfc_warning_check ();
2530 gfc_clear_new_st ();
2534 /* Undo anything tentative that has been built for the current statement,
2535 except if a gfc_charlen structure has been added to current namespace's
2536 list of gfc_charlen structure. */
2539 reject_statement (void)
2541 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
2542 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
2544 gfc_reject_data (gfc_current_ns
);
2546 gfc_new_block
= NULL
;
2547 gfc_undo_symbols ();
2548 gfc_clear_warning ();
2549 undo_new_statement ();
2553 /* Generic complaint about an out of order statement. We also do
2554 whatever is necessary to clean up. */
2557 unexpected_statement (gfc_statement st
)
2559 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
2561 reject_statement ();
2565 /* Given the next statement seen by the matcher, make sure that it is
2566 in proper order with the last. This subroutine is initialized by
2567 calling it with an argument of ST_NONE. If there is a problem, we
2568 issue an error and return false. Otherwise we return true.
2570 Individual parsers need to verify that the statements seen are
2571 valid before calling here, i.e., ENTRY statements are not allowed in
2572 INTERFACE blocks. The following diagram is taken from the standard:
2574 +---------------------------------------+
2575 | program subroutine function module |
2576 +---------------------------------------+
2578 +---------------------------------------+
2580 +---------------------------------------+
2582 | +-----------+------------------+
2583 | | parameter | implicit |
2584 | +-----------+------------------+
2585 | format | | derived type |
2586 | entry | parameter | interface |
2587 | | data | specification |
2588 | | | statement func |
2589 | +-----------+------------------+
2590 | | data | executable |
2591 +--------+-----------+------------------+
2593 +---------------------------------------+
2594 | internal module/subprogram |
2595 +---------------------------------------+
2597 +---------------------------------------+
2606 ORDER_IMPLICIT_NONE
,
2614 enum state_order state
;
2615 gfc_statement last_statement
;
2621 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
2627 p
->state
= ORDER_START
;
2631 if (p
->state
> ORDER_USE
)
2633 p
->state
= ORDER_USE
;
2637 if (p
->state
> ORDER_IMPORT
)
2639 p
->state
= ORDER_IMPORT
;
2642 case ST_IMPLICIT_NONE
:
2643 if (p
->state
> ORDER_IMPLICIT
)
2646 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2647 statement disqualifies a USE but not an IMPLICIT NONE.
2648 Duplicate IMPLICIT NONEs are caught when the implicit types
2651 p
->state
= ORDER_IMPLICIT_NONE
;
2655 if (p
->state
> ORDER_IMPLICIT
)
2657 p
->state
= ORDER_IMPLICIT
;
2662 if (p
->state
< ORDER_IMPLICIT_NONE
)
2663 p
->state
= ORDER_IMPLICIT_NONE
;
2667 if (p
->state
>= ORDER_EXEC
)
2669 if (p
->state
< ORDER_IMPLICIT
)
2670 p
->state
= ORDER_IMPLICIT
;
2674 if (p
->state
< ORDER_SPEC
)
2675 p
->state
= ORDER_SPEC
;
2680 case ST_STRUCTURE_DECL
:
2681 case ST_DERIVED_DECL
:
2683 if (p
->state
>= ORDER_EXEC
)
2685 if (p
->state
< ORDER_SPEC
)
2686 p
->state
= ORDER_SPEC
;
2690 /* The OpenMP directives have to be somewhere in the specification
2691 part, but there are no further requirements on their ordering.
2692 Thus don't adjust p->state, just ignore them. */
2693 if (p
->state
>= ORDER_EXEC
)
2699 if (p
->state
< ORDER_EXEC
)
2700 p
->state
= ORDER_EXEC
;
2707 /* All is well, record the statement in case we need it next time. */
2708 p
->where
= gfc_current_locus
;
2709 p
->last_statement
= st
;
2714 gfc_error ("%s statement at %C cannot follow %s statement at %L",
2715 gfc_ascii_statement (st
),
2716 gfc_ascii_statement (p
->last_statement
), &p
->where
);
2722 /* Handle an unexpected end of file. This is a show-stopper... */
2724 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
2727 unexpected_eof (void)
2731 gfc_error ("Unexpected end of file in %qs", gfc_source_file
);
2733 /* Memory cleanup. Move to "second to last". */
2734 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
2737 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
2740 longjmp (eof_buf
, 1);
2742 /* Avoids build error on systems where longjmp is not declared noreturn. */
2747 /* Parse the CONTAINS section of a derived type definition. */
2749 gfc_access gfc_typebound_default_access
;
2752 parse_derived_contains (void)
2755 bool seen_private
= false;
2756 bool seen_comps
= false;
2757 bool error_flag
= false;
2760 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2761 gcc_assert (gfc_current_block ());
2763 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
2765 if (gfc_current_block ()->attr
.sequence
)
2766 gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
2767 " section at %C", gfc_current_block ()->name
);
2768 if (gfc_current_block ()->attr
.is_bind_c
)
2769 gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
2770 " section at %C", gfc_current_block ()->name
);
2772 accept_statement (ST_CONTAINS
);
2773 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
2775 gfc_typebound_default_access
= ACCESS_PUBLIC
;
2781 st
= next_statement ();
2789 gfc_error ("Components in TYPE at %C must precede CONTAINS");
2793 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
2796 accept_statement (ST_PROCEDURE
);
2801 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
2804 accept_statement (ST_GENERIC
);
2809 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
2813 accept_statement (ST_FINAL
);
2821 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
2822 "at %C with empty CONTAINS section")))
2825 /* ST_END_TYPE is accepted by parse_derived after return. */
2829 if (!gfc_find_state (COMP_MODULE
))
2831 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2838 gfc_error ("PRIVATE statement at %C must precede procedure"
2845 gfc_error ("Duplicate PRIVATE statement at %C");
2849 accept_statement (ST_PRIVATE
);
2850 gfc_typebound_default_access
= ACCESS_PRIVATE
;
2851 seen_private
= true;
2855 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2859 gfc_error ("Already inside a CONTAINS block at %C");
2863 unexpected_statement (st
);
2871 reject_statement ();
2875 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2881 /* Set attributes for the parent symbol based on the attributes of a component
2882 and raise errors if conflicting attributes are found for the component. */
2885 check_component (gfc_symbol
*sym
, gfc_component
*c
, gfc_component
**lockp
,
2886 gfc_component
**eventp
)
2888 bool coarray
, lock_type
, event_type
, allocatable
, pointer
;
2889 coarray
= lock_type
= event_type
= allocatable
= pointer
= false;
2890 gfc_component
*lock_comp
= NULL
, *event_comp
= NULL
;
2892 if (lockp
) lock_comp
= *lockp
;
2893 if (eventp
) event_comp
= *eventp
;
2895 /* Look for allocatable components. */
2896 if (c
->attr
.allocatable
2897 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2898 && CLASS_DATA (c
)->attr
.allocatable
)
2899 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
2900 && c
->ts
.u
.derived
->attr
.alloc_comp
))
2903 sym
->attr
.alloc_comp
= 1;
2906 /* Look for pointer components. */
2908 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2909 && CLASS_DATA (c
)->attr
.class_pointer
)
2910 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
2913 sym
->attr
.pointer_comp
= 1;
2916 /* Look for procedure pointer components. */
2917 if (c
->attr
.proc_pointer
2918 || (c
->ts
.type
== BT_DERIVED
2919 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
2920 sym
->attr
.proc_pointer_comp
= 1;
2922 /* Looking for coarray components. */
2923 if (c
->attr
.codimension
2924 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2925 && CLASS_DATA (c
)->attr
.codimension
))
2928 sym
->attr
.coarray_comp
= 1;
2931 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
2932 && !c
->attr
.pointer
)
2935 sym
->attr
.coarray_comp
= 1;
2938 /* Looking for lock_type components. */
2939 if ((c
->ts
.type
== BT_DERIVED
2940 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2941 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2942 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2943 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2944 == INTMOD_ISO_FORTRAN_ENV
2945 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2946 == ISOFORTRAN_LOCK_TYPE
)
2947 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
2948 && !allocatable
&& !pointer
))
2952 sym
->attr
.lock_comp
= 1;
2955 /* Looking for event_type components. */
2956 if ((c
->ts
.type
== BT_DERIVED
2957 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2958 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2959 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2960 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2961 == INTMOD_ISO_FORTRAN_ENV
2962 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2963 == ISOFORTRAN_EVENT_TYPE
)
2964 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.event_comp
2965 && !allocatable
&& !pointer
))
2969 sym
->attr
.event_comp
= 1;
2972 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2973 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2974 unless there are nondirect [allocatable or pointer] components
2975 involved (cf. 1.3.33.1 and 1.3.33.3). */
2977 if (pointer
&& !coarray
&& lock_type
)
2978 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2979 "codimension or be a subcomponent of a coarray, "
2980 "which is not possible as the component has the "
2981 "pointer attribute", c
->name
, &c
->loc
);
2982 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
2983 && c
->ts
.u
.derived
->attr
.lock_comp
)
2984 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2985 "of type LOCK_TYPE, which must have a codimension or be a "
2986 "subcomponent of a coarray", c
->name
, &c
->loc
);
2988 if (lock_type
&& allocatable
&& !coarray
)
2989 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
2990 "a codimension", c
->name
, &c
->loc
);
2991 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
2992 && c
->ts
.u
.derived
->attr
.lock_comp
)
2993 gfc_error ("Allocatable component %s at %L must have a codimension as "
2994 "it has a noncoarray subcomponent of type LOCK_TYPE",
2997 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
2998 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2999 "subcomponent of type LOCK_TYPE must have a codimension or "
3000 "be a subcomponent of a coarray. (Variables of type %s may "
3001 "not have a codimension as already a coarray "
3002 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
3004 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
3005 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3006 "subcomponent of type LOCK_TYPE must have a codimension or "
3007 "be a subcomponent of a coarray. (Variables of type %s may "
3008 "not have a codimension as %s at %L has a codimension or a "
3009 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
3010 sym
->name
, c
->name
, &c
->loc
);
3012 /* Similarly for EVENT TYPE. */
3014 if (pointer
&& !coarray
&& event_type
)
3015 gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
3016 "codimension or be a subcomponent of a coarray, "
3017 "which is not possible as the component has the "
3018 "pointer attribute", c
->name
, &c
->loc
);
3019 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
3020 && c
->ts
.u
.derived
->attr
.event_comp
)
3021 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3022 "of type EVENT_TYPE, which must have a codimension or be a "
3023 "subcomponent of a coarray", c
->name
, &c
->loc
);
3025 if (event_type
&& allocatable
&& !coarray
)
3026 gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
3027 "a codimension", c
->name
, &c
->loc
);
3028 else if (event_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
3029 && c
->ts
.u
.derived
->attr
.event_comp
)
3030 gfc_error ("Allocatable component %s at %L must have a codimension as "
3031 "it has a noncoarray subcomponent of type EVENT_TYPE",
3034 if (sym
->attr
.coarray_comp
&& !coarray
&& event_type
)
3035 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3036 "subcomponent of type EVENT_TYPE must have a codimension or "
3037 "be a subcomponent of a coarray. (Variables of type %s may "
3038 "not have a codimension as already a coarray "
3039 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
3041 if (sym
->attr
.event_comp
&& coarray
&& !event_type
)
3042 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3043 "subcomponent of type EVENT_TYPE must have a codimension or "
3044 "be a subcomponent of a coarray. (Variables of type %s may "
3045 "not have a codimension as %s at %L has a codimension or a "
3046 "coarray subcomponent)", event_comp
->name
, &event_comp
->loc
,
3047 sym
->name
, c
->name
, &c
->loc
);
3049 /* Look for private components. */
3050 if (sym
->component_access
== ACCESS_PRIVATE
3051 || c
->attr
.access
== ACCESS_PRIVATE
3052 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
3053 sym
->attr
.private_comp
= 1;
3055 if (lockp
) *lockp
= lock_comp
;
3056 if (eventp
) *eventp
= event_comp
;
3060 static void parse_struct_map (gfc_statement
);
3062 /* Parse a union component definition within a structure definition. */
3070 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3073 accept_statement(ST_UNION
);
3074 push_state (&s
, COMP_UNION
, gfc_new_block
);
3081 st
= next_statement ();
3082 /* Only MAP declarations valid within a union. */
3089 accept_statement (ST_MAP
);
3090 parse_struct_map (ST_MAP
);
3091 /* Add a component to the union for each map. */
3092 if (!gfc_add_component (un
, gfc_new_block
->name
, &c
))
3094 gfc_internal_error ("failed to create map component '%s'",
3095 gfc_new_block
->name
);
3096 reject_statement ();
3099 c
->ts
.type
= BT_DERIVED
;
3100 c
->ts
.u
.derived
= gfc_new_block
;
3101 /* Normally components get their initialization expressions when they
3102 are created in decl.c (build_struct) so we can look through the
3103 flat component list for initializers during resolution. Unions and
3104 maps create components along with their type definitions so we
3105 have to generate initializers here. */
3106 c
->initializer
= gfc_default_initializer (&c
->ts
);
3111 accept_statement (ST_END_UNION
);
3115 unexpected_statement (st
);
3120 for (c
= un
->components
; c
; c
= c
->next
)
3121 check_component (un
, c
, &lock_comp
, &event_comp
);
3123 /* Add the union as a component in its parent structure. */
3125 if (!gfc_add_component (gfc_current_block (), un
->name
, &c
))
3127 gfc_internal_error ("failed to create union component '%s'", un
->name
);
3128 reject_statement ();
3131 c
->ts
.type
= BT_UNION
;
3132 c
->ts
.u
.derived
= un
;
3133 c
->initializer
= gfc_default_initializer (&c
->ts
);
3135 un
->attr
.zero_comp
= un
->components
== NULL
;
3139 /* Parse a STRUCTURE or MAP. */
3142 parse_struct_map (gfc_statement block
)
3148 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3149 gfc_compile_state comp
;
3152 if (block
== ST_STRUCTURE_DECL
)
3154 comp
= COMP_STRUCTURE
;
3155 ends
= ST_END_STRUCTURE
;
3159 gcc_assert (block
== ST_MAP
);
3164 accept_statement(block
);
3165 push_state (&s
, comp
, gfc_new_block
);
3167 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3170 while (compiling_type
)
3172 st
= next_statement ();
3178 /* Nested structure declarations will be captured as ST_DATA_DECL. */
3179 case ST_STRUCTURE_DECL
:
3180 /* Let a more specific error make it to decode_statement(). */
3181 if (gfc_error_check () == 0)
3182 gfc_error ("Syntax error in nested structure declaration at %C");
3183 reject_statement ();
3184 /* Skip the rest of this statement. */
3185 gfc_error_recovery ();
3189 accept_statement (ST_UNION
);
3194 /* The data declaration was a nested/ad-hoc STRUCTURE field. */
3195 accept_statement (ST_DATA_DECL
);
3196 if (gfc_new_block
&& gfc_new_block
!= gfc_current_block ()
3197 && gfc_new_block
->attr
.flavor
== FL_STRUCT
)
3198 parse_struct_map (ST_STRUCTURE_DECL
);
3201 case ST_END_STRUCTURE
:
3205 accept_statement (st
);
3209 unexpected_statement (st
);
3213 unexpected_statement (st
);
3218 /* Validate each component. */
3219 sym
= gfc_current_block ();
3220 for (c
= sym
->components
; c
; c
= c
->next
)
3221 check_component (sym
, c
, &lock_comp
, &event_comp
);
3223 sym
->attr
.zero_comp
= (sym
->components
== NULL
);
3225 /* Allow parse_union to find this structure to add to its list of maps. */
3226 if (block
== ST_MAP
)
3227 gfc_new_block
= gfc_current_block ();
3233 /* Parse a derived type. */
3236 parse_derived (void)
3238 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
3242 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3244 accept_statement (ST_DERIVED_DECL
);
3245 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
3247 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3254 while (compiling_type
)
3256 st
= next_statement ();
3264 accept_statement (st
);
3269 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
3276 if (!seen_component
)
3277 gfc_notify_std (GFC_STD_F2003
, "Derived type "
3278 "definition at %C without components");
3280 accept_statement (ST_END_TYPE
);
3284 if (!gfc_find_state (COMP_MODULE
))
3286 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3293 gfc_error ("PRIVATE statement at %C must precede "
3294 "structure components");
3299 gfc_error ("Duplicate PRIVATE statement at %C");
3301 s
.sym
->component_access
= ACCESS_PRIVATE
;
3303 accept_statement (ST_PRIVATE
);
3310 gfc_error ("SEQUENCE statement at %C must precede "
3311 "structure components");
3315 if (gfc_current_block ()->attr
.sequence
)
3316 gfc_warning (0, "SEQUENCE attribute at %C already specified in "
3321 gfc_error ("Duplicate SEQUENCE statement at %C");
3325 gfc_add_sequence (&gfc_current_block ()->attr
,
3326 gfc_current_block ()->name
, NULL
);
3330 gfc_notify_std (GFC_STD_F2003
,
3331 "CONTAINS block in derived type"
3332 " definition at %C");
3334 accept_statement (ST_CONTAINS
);
3335 parse_derived_contains ();
3339 unexpected_statement (st
);
3344 /* need to verify that all fields of the derived type are
3345 * interoperable with C if the type is declared to be bind(c)
3347 sym
= gfc_current_block ();
3348 for (c
= sym
->components
; c
; c
= c
->next
)
3349 check_component (sym
, c
, &lock_comp
, &event_comp
);
3351 if (!seen_component
)
3352 sym
->attr
.zero_comp
= 1;
3358 /* Parse an ENUM. */
3366 int seen_enumerator
= 0;
3368 push_state (&s
, COMP_ENUM
, gfc_new_block
);
3372 while (compiling_enum
)
3374 st
= next_statement ();
3382 seen_enumerator
= 1;
3383 accept_statement (st
);
3388 if (!seen_enumerator
)
3389 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
3390 accept_statement (st
);
3394 gfc_free_enum_history ();
3395 unexpected_statement (st
);
3403 /* Parse an interface. We must be able to deal with the possibility
3404 of recursive interfaces. The parse_spec() subroutine is mutually
3405 recursive with parse_interface(). */
3407 static gfc_statement
parse_spec (gfc_statement
);
3410 parse_interface (void)
3412 gfc_compile_state new_state
= COMP_NONE
, current_state
;
3413 gfc_symbol
*prog_unit
, *sym
;
3414 gfc_interface_info save
;
3415 gfc_state_data s1
, s2
;
3418 accept_statement (ST_INTERFACE
);
3420 current_interface
.ns
= gfc_current_ns
;
3421 save
= current_interface
;
3423 sym
= (current_interface
.type
== INTERFACE_GENERIC
3424 || current_interface
.type
== INTERFACE_USER_OP
)
3425 ? gfc_new_block
: NULL
;
3427 push_state (&s1
, COMP_INTERFACE
, sym
);
3428 current_state
= COMP_NONE
;
3431 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
3433 st
= next_statement ();
3441 if (st
== ST_SUBROUTINE
)
3442 new_state
= COMP_SUBROUTINE
;
3443 else if (st
== ST_FUNCTION
)
3444 new_state
= COMP_FUNCTION
;
3445 if (gfc_new_block
->attr
.pointer
)
3447 gfc_new_block
->attr
.pointer
= 0;
3448 gfc_new_block
->attr
.proc_pointer
= 1;
3450 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
3451 gfc_new_block
->formal
, NULL
))
3453 reject_statement ();
3454 gfc_free_namespace (gfc_current_ns
);
3457 /* F2008 C1210 forbids the IMPORT statement in module procedure
3458 interface bodies and the flag is set to import symbols. */
3459 if (gfc_new_block
->attr
.module_procedure
)
3460 gfc_current_ns
->has_import_set
= 1;
3464 case ST_MODULE_PROC
: /* The module procedure matcher makes
3465 sure the context is correct. */
3466 accept_statement (st
);
3467 gfc_free_namespace (gfc_current_ns
);
3470 case ST_END_INTERFACE
:
3471 gfc_free_namespace (gfc_current_ns
);
3472 gfc_current_ns
= current_interface
.ns
;
3476 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
3477 gfc_ascii_statement (st
));
3478 reject_statement ();
3479 gfc_free_namespace (gfc_current_ns
);
3484 /* Make sure that the generic name has the right attribute. */
3485 if (current_interface
.type
== INTERFACE_GENERIC
3486 && current_state
== COMP_NONE
)
3488 if (new_state
== COMP_FUNCTION
&& sym
)
3489 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
3490 else if (new_state
== COMP_SUBROUTINE
&& sym
)
3491 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
3493 current_state
= new_state
;
3496 if (current_interface
.type
== INTERFACE_ABSTRACT
)
3498 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
3499 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
3500 gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
3501 "cannot be the same as an intrinsic type",
3502 gfc_new_block
->name
);
3505 push_state (&s2
, new_state
, gfc_new_block
);
3506 accept_statement (st
);
3507 prog_unit
= gfc_new_block
;
3508 prog_unit
->formal_ns
= gfc_current_ns
;
3509 if (prog_unit
== prog_unit
->formal_ns
->proc_name
3510 && prog_unit
->ns
!= prog_unit
->formal_ns
)
3514 /* Read data declaration statements. */
3515 st
= parse_spec (ST_NONE
);
3516 in_specification_block
= true;
3518 /* Since the interface block does not permit an IMPLICIT statement,
3519 the default type for the function or the result must be taken
3520 from the formal namespace. */
3521 if (new_state
== COMP_FUNCTION
)
3523 if (prog_unit
->result
== prog_unit
3524 && prog_unit
->ts
.type
== BT_UNKNOWN
)
3525 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
3526 else if (prog_unit
->result
!= prog_unit
3527 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
3528 gfc_set_default_type (prog_unit
->result
, 1,
3529 prog_unit
->formal_ns
);
3532 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
3534 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
3535 gfc_ascii_statement (st
));
3536 reject_statement ();
3540 /* Add EXTERNAL attribute to function or subroutine. */
3541 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
3542 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
3544 current_interface
= save
;
3545 gfc_add_interface (prog_unit
);
3548 if (current_interface
.ns
3549 && current_interface
.ns
->proc_name
3550 && strcmp (current_interface
.ns
->proc_name
->name
,
3551 prog_unit
->name
) == 0)
3552 gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
3553 "enclosing procedure", prog_unit
->name
,
3554 ¤t_interface
.ns
->proc_name
->declared_at
);
3563 /* Associate function characteristics by going back to the function
3564 declaration and rematching the prefix. */
3567 match_deferred_characteristics (gfc_typespec
* ts
)
3570 match m
= MATCH_ERROR
;
3571 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3573 loc
= gfc_current_locus
;
3575 gfc_current_locus
= gfc_current_block ()->declared_at
;
3578 gfc_buffer_error (true);
3579 m
= gfc_match_prefix (ts
);
3580 gfc_buffer_error (false);
3582 if (ts
->type
== BT_DERIVED
)
3590 /* Only permit one go at the characteristic association. */
3594 /* Set the function locus correctly. If we have not found the
3595 function name, there is an error. */
3597 && gfc_match ("function% %n", name
) == MATCH_YES
3598 && strcmp (name
, gfc_current_block ()->name
) == 0)
3600 gfc_current_block ()->declared_at
= gfc_current_locus
;
3601 gfc_commit_symbols ();
3606 gfc_undo_symbols ();
3609 gfc_current_locus
=loc
;
3614 /* Check specification-expressions in the function result of the currently
3615 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
3616 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
3617 scope are not yet parsed so this has to be delayed up to parse_spec. */
3620 check_function_result_typed (void)
3624 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
3626 if (!gfc_current_ns
->proc_name
->result
) return;
3628 ts
= gfc_current_ns
->proc_name
->result
->ts
;
3630 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
3631 /* TODO: Extend when KIND type parameters are implemented. */
3632 if (ts
.type
== BT_CHARACTER
&& ts
.u
.cl
&& ts
.u
.cl
->length
)
3633 gfc_expr_check_typed (ts
.u
.cl
->length
, gfc_current_ns
, true);
3637 /* Parse a set of specification statements. Returns the statement
3638 that doesn't fit. */
3640 static gfc_statement
3641 parse_spec (gfc_statement st
)
3644 bool function_result_typed
= false;
3645 bool bad_characteristic
= false;
3648 in_specification_block
= true;
3650 verify_st_order (&ss
, ST_NONE
, false);
3652 st
= next_statement ();
3654 /* If we are not inside a function or don't have a result specified so far,
3655 do nothing special about it. */
3656 if (gfc_current_state () != COMP_FUNCTION
)
3657 function_result_typed
= true;
3660 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
3663 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
3664 function_result_typed
= true;
3669 /* If we're inside a BLOCK construct, some statements are disallowed.
3670 Check this here. Attribute declaration statements like INTENT, OPTIONAL
3671 or VALUE are also disallowed, but they don't have a particular ST_*
3672 key so we have to check for them individually in their matcher routine. */
3673 if (gfc_current_state () == COMP_BLOCK
)
3677 case ST_IMPLICIT_NONE
:
3680 case ST_EQUIVALENCE
:
3681 case ST_STATEMENT_FUNCTION
:
3682 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
3683 gfc_ascii_statement (st
));
3684 reject_statement ();
3690 else if (gfc_current_state () == COMP_BLOCK_DATA
)
3691 /* Fortran 2008, C1116. */
3698 case ST_DERIVED_DECL
:
3699 case ST_END_BLOCK_DATA
:
3700 case ST_EQUIVALENCE
:
3702 case ST_IMPLICIT_NONE
:
3703 case ST_OMP_THREADPRIVATE
:
3705 case ST_STRUCTURE_DECL
:
3714 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
3715 gfc_ascii_statement (st
));
3716 reject_statement ();
3720 /* If we find a statement that can not be followed by an IMPLICIT statement
3721 (and thus we can expect to see none any further), type the function result
3722 if it has not yet been typed. Be careful not to give the END statement
3723 to verify_st_order! */
3724 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
3726 bool verify_now
= false;
3728 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
3733 verify_st_order (&dummyss
, ST_NONE
, false);
3734 verify_st_order (&dummyss
, st
, false);
3736 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
3742 check_function_result_typed ();
3743 function_result_typed
= true;
3752 case ST_IMPLICIT_NONE
:
3754 if (!function_result_typed
)
3756 check_function_result_typed ();
3757 function_result_typed
= true;
3763 case ST_DATA
: /* Not allowed in interfaces */
3764 if (gfc_current_state () == COMP_INTERFACE
)
3774 case ST_STRUCTURE_DECL
:
3775 case ST_DERIVED_DECL
:
3779 if (!verify_st_order (&ss
, st
, false))
3781 reject_statement ();
3782 st
= next_statement ();
3792 case ST_STRUCTURE_DECL
:
3793 parse_struct_map (ST_STRUCTURE_DECL
);
3796 case ST_DERIVED_DECL
:
3802 if (gfc_current_state () != COMP_MODULE
)
3804 gfc_error ("%s statement must appear in a MODULE",
3805 gfc_ascii_statement (st
));
3806 reject_statement ();
3810 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
3812 gfc_error ("%s statement at %C follows another accessibility "
3813 "specification", gfc_ascii_statement (st
));
3814 reject_statement ();
3818 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
3819 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3823 case ST_STATEMENT_FUNCTION
:
3824 if (gfc_current_state () == COMP_MODULE
3825 || gfc_current_state () == COMP_SUBMODULE
)
3827 unexpected_statement (st
);
3835 accept_statement (st
);
3836 st
= next_statement ();
3840 accept_statement (st
);
3842 st
= next_statement ();
3845 case ST_GET_FCN_CHARACTERISTICS
:
3846 /* This statement triggers the association of a function's result
3848 ts
= &gfc_current_block ()->result
->ts
;
3849 if (match_deferred_characteristics (ts
) != MATCH_YES
)
3850 bad_characteristic
= true;
3852 st
= next_statement ();
3859 /* If match_deferred_characteristics failed, then there is an error. */
3860 if (bad_characteristic
)
3862 ts
= &gfc_current_block ()->result
->ts
;
3863 if (ts
->type
!= BT_DERIVED
)
3864 gfc_error ("Bad kind expression for function %qs at %L",
3865 gfc_current_block ()->name
,
3866 &gfc_current_block ()->declared_at
);
3868 gfc_error ("The type for function %qs at %L is not accessible",
3869 gfc_current_block ()->name
,
3870 &gfc_current_block ()->declared_at
);
3872 gfc_current_block ()->ts
.kind
= 0;
3873 /* Keep the derived type; if it's bad, it will be discovered later. */
3874 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
3875 ts
->type
= BT_UNKNOWN
;
3878 in_specification_block
= false;
3884 /* Parse a WHERE block, (not a simple WHERE statement). */
3887 parse_where_block (void)
3889 int seen_empty_else
;
3894 accept_statement (ST_WHERE_BLOCK
);
3895 top
= gfc_state_stack
->tail
;
3897 push_state (&s
, COMP_WHERE
, gfc_new_block
);
3899 d
= add_statement ();
3900 d
->expr1
= top
->expr1
;
3906 seen_empty_else
= 0;
3910 st
= next_statement ();
3916 case ST_WHERE_BLOCK
:
3917 parse_where_block ();
3922 accept_statement (st
);
3926 if (seen_empty_else
)
3928 gfc_error ("ELSEWHERE statement at %C follows previous "
3929 "unmasked ELSEWHERE");
3930 reject_statement ();
3934 if (new_st
.expr1
== NULL
)
3935 seen_empty_else
= 1;
3937 d
= new_level (gfc_state_stack
->head
);
3939 d
->expr1
= new_st
.expr1
;
3941 accept_statement (st
);
3946 accept_statement (st
);
3950 gfc_error ("Unexpected %s statement in WHERE block at %C",
3951 gfc_ascii_statement (st
));
3952 reject_statement ();
3956 while (st
!= ST_END_WHERE
);
3962 /* Parse a FORALL block (not a simple FORALL statement). */
3965 parse_forall_block (void)
3971 accept_statement (ST_FORALL_BLOCK
);
3972 top
= gfc_state_stack
->tail
;
3974 push_state (&s
, COMP_FORALL
, gfc_new_block
);
3976 d
= add_statement ();
3977 d
->op
= EXEC_FORALL
;
3982 st
= next_statement ();
3987 case ST_POINTER_ASSIGNMENT
:
3990 accept_statement (st
);
3993 case ST_WHERE_BLOCK
:
3994 parse_where_block ();
3997 case ST_FORALL_BLOCK
:
3998 parse_forall_block ();
4002 accept_statement (st
);
4009 gfc_error ("Unexpected %s statement in FORALL block at %C",
4010 gfc_ascii_statement (st
));
4012 reject_statement ();
4016 while (st
!= ST_END_FORALL
);
4022 static gfc_statement
parse_executable (gfc_statement
);
4024 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
4027 parse_if_block (void)
4036 accept_statement (ST_IF_BLOCK
);
4038 top
= gfc_state_stack
->tail
;
4039 push_state (&s
, COMP_IF
, gfc_new_block
);
4041 new_st
.op
= EXEC_IF
;
4042 d
= add_statement ();
4044 d
->expr1
= top
->expr1
;
4050 st
= parse_executable (ST_NONE
);
4060 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
4061 "statement at %L", &else_locus
);
4063 reject_statement ();
4067 d
= new_level (gfc_state_stack
->head
);
4069 d
->expr1
= new_st
.expr1
;
4071 accept_statement (st
);
4078 gfc_error ("Duplicate ELSE statements at %L and %C",
4080 reject_statement ();
4085 else_locus
= gfc_current_locus
;
4087 d
= new_level (gfc_state_stack
->head
);
4090 accept_statement (st
);
4098 unexpected_statement (st
);
4102 while (st
!= ST_ENDIF
);
4105 accept_statement (st
);
4109 /* Parse a SELECT block. */
4112 parse_select_block (void)
4118 accept_statement (ST_SELECT_CASE
);
4120 cp
= gfc_state_stack
->tail
;
4121 push_state (&s
, COMP_SELECT
, gfc_new_block
);
4123 /* Make sure that the next statement is a CASE or END SELECT. */
4126 st
= next_statement ();
4129 if (st
== ST_END_SELECT
)
4131 /* Empty SELECT CASE is OK. */
4132 accept_statement (st
);
4139 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
4142 reject_statement ();
4145 /* At this point, we're got a nonempty select block. */
4146 cp
= new_level (cp
);
4149 accept_statement (st
);
4153 st
= parse_executable (ST_NONE
);
4160 cp
= new_level (gfc_state_stack
->head
);
4162 gfc_clear_new_st ();
4164 accept_statement (st
);
4170 /* Can't have an executable statement because of
4171 parse_executable(). */
4173 unexpected_statement (st
);
4177 while (st
!= ST_END_SELECT
);
4180 accept_statement (st
);
4184 /* Pop the current selector from the SELECT TYPE stack. */
4187 select_type_pop (void)
4189 gfc_select_type_stack
*old
= select_type_stack
;
4190 select_type_stack
= old
->prev
;
4195 /* Parse a SELECT TYPE construct (F03:R821). */
4198 parse_select_type_block (void)
4204 gfc_current_ns
= new_st
.ext
.block
.ns
;
4205 accept_statement (ST_SELECT_TYPE
);
4207 cp
= gfc_state_stack
->tail
;
4208 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
4210 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
4214 st
= next_statement ();
4217 if (st
== ST_END_SELECT
)
4218 /* Empty SELECT CASE is OK. */
4220 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
4223 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
4224 "following SELECT TYPE at %C");
4226 reject_statement ();
4229 /* At this point, we're got a nonempty select block. */
4230 cp
= new_level (cp
);
4233 accept_statement (st
);
4237 st
= parse_executable (ST_NONE
);
4245 cp
= new_level (gfc_state_stack
->head
);
4247 gfc_clear_new_st ();
4249 accept_statement (st
);
4255 /* Can't have an executable statement because of
4256 parse_executable(). */
4258 unexpected_statement (st
);
4262 while (st
!= ST_END_SELECT
);
4266 accept_statement (st
);
4267 gfc_current_ns
= gfc_current_ns
->parent
;
4272 /* Given a symbol, make sure it is not an iteration variable for a DO
4273 statement. This subroutine is called when the symbol is seen in a
4274 context that causes it to become redefined. If the symbol is an
4275 iterator, we generate an error message and return nonzero. */
4278 gfc_check_do_variable (gfc_symtree
*st
)
4282 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
4283 if (s
->do_variable
== st
)
4285 gfc_error_now ("Variable %qs at %C cannot be redefined inside "
4286 "loop beginning at %L", st
->name
, &s
->head
->loc
);
4294 /* Checks to see if the current statement label closes an enddo.
4295 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
4296 an error) if it incorrectly closes an ENDDO. */
4299 check_do_closure (void)
4303 if (gfc_statement_label
== NULL
)
4306 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
4307 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4311 return 0; /* No loops to close */
4313 if (p
->ext
.end_do_label
== gfc_statement_label
)
4315 if (p
== gfc_state_stack
)
4318 gfc_error ("End of nonblock DO statement at %C is within another block");
4322 /* At this point, the label doesn't terminate the innermost loop.
4323 Make sure it doesn't terminate another one. */
4324 for (; p
; p
= p
->previous
)
4325 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4326 && p
->ext
.end_do_label
== gfc_statement_label
)
4328 gfc_error ("End of nonblock DO statement at %C is interwoven "
4329 "with another DO loop");
4337 /* Parse a series of contained program units. */
4339 static void parse_progunit (gfc_statement
);
4342 /* Parse a CRITICAL block. */
4345 parse_critical_block (void)
4348 gfc_state_data s
, *sd
;
4351 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4352 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
4353 gfc_error_now (is_oacc (sd
)
4354 ? G_("CRITICAL block inside of OpenACC region at %C")
4355 : G_("CRITICAL block inside of OpenMP region at %C"));
4357 s
.ext
.end_do_label
= new_st
.label1
;
4359 accept_statement (ST_CRITICAL
);
4360 top
= gfc_state_stack
->tail
;
4362 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
4364 d
= add_statement ();
4365 d
->op
= EXEC_CRITICAL
;
4370 st
= parse_executable (ST_NONE
);
4378 case ST_END_CRITICAL
:
4379 if (s
.ext
.end_do_label
!= NULL
4380 && s
.ext
.end_do_label
!= gfc_statement_label
)
4381 gfc_error_now ("Statement label in END CRITICAL at %C does not "
4382 "match CRITICAL label");
4384 if (gfc_statement_label
!= NULL
)
4386 new_st
.op
= EXEC_NOP
;
4392 unexpected_statement (st
);
4396 while (st
!= ST_END_CRITICAL
);
4399 accept_statement (st
);
4403 /* Set up the local namespace for a BLOCK construct. */
4406 gfc_build_block_ns (gfc_namespace
*parent_ns
)
4408 gfc_namespace
* my_ns
;
4409 static int numblock
= 1;
4411 my_ns
= gfc_get_namespace (parent_ns
, 1);
4412 my_ns
->construct_entities
= 1;
4414 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
4415 code generation (so it must not be NULL).
4416 We set its recursive argument if our container procedure is recursive, so
4417 that local variables are accordingly placed on the stack when it
4418 will be necessary. */
4420 my_ns
->proc_name
= gfc_new_block
;
4424 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
4426 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
4427 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
4428 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
4429 my_ns
->proc_name
->name
, NULL
);
4431 gfc_commit_symbol (my_ns
->proc_name
);
4434 if (parent_ns
->proc_name
)
4435 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
4441 /* Parse a BLOCK construct. */
4444 parse_block_construct (void)
4446 gfc_namespace
* my_ns
;
4447 gfc_namespace
* my_parent
;
4450 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
4452 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4454 new_st
.op
= EXEC_BLOCK
;
4455 new_st
.ext
.block
.ns
= my_ns
;
4456 new_st
.ext
.block
.assoc
= NULL
;
4457 accept_statement (ST_BLOCK
);
4459 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
4460 gfc_current_ns
= my_ns
;
4461 my_parent
= my_ns
->parent
;
4463 parse_progunit (ST_NONE
);
4465 /* Don't depend on the value of gfc_current_ns; it might have been
4466 reset if the block had errors and was cleaned up. */
4467 gfc_current_ns
= my_parent
;
4473 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
4474 behind the scenes with compiler-generated variables. */
4477 parse_associate (void)
4479 gfc_namespace
* my_ns
;
4482 gfc_association_list
* a
;
4484 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
4486 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4488 new_st
.op
= EXEC_BLOCK
;
4489 new_st
.ext
.block
.ns
= my_ns
;
4490 gcc_assert (new_st
.ext
.block
.assoc
);
4492 /* Add all associate-names as BLOCK variables. Creating them is enough
4493 for now, they'll get their values during trans-* phase. */
4494 gfc_current_ns
= my_ns
;
4495 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
4499 gfc_array_ref
*array_ref
;
4501 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
4505 sym
->attr
.flavor
= FL_VARIABLE
;
4507 sym
->declared_at
= a
->where
;
4508 gfc_set_sym_referenced (sym
);
4510 /* Initialize the typespec. It is not available in all cases,
4511 however, as it may only be set on the target during resolution.
4512 Still, sometimes it helps to have it right now -- especially
4513 for parsing component references on the associate-name
4514 in case of association to a derived-type. */
4515 sym
->ts
= a
->target
->ts
;
4517 /* Check if the target expression is array valued. This can not always
4518 be done by looking at target.rank, because that might not have been
4519 set yet. Therefore traverse the chain of refs, looking for the last
4520 array ref and evaluate that. */
4522 for (ref
= a
->target
->ref
; ref
; ref
= ref
->next
)
4523 if (ref
->type
== REF_ARRAY
)
4524 array_ref
= &ref
->u
.ar
;
4525 if (array_ref
|| a
->target
->rank
)
4532 /* Count the dimension, that have a non-scalar extend. */
4533 for (dim
= 0; dim
< array_ref
->dimen
; ++dim
)
4534 if (array_ref
->dimen_type
[dim
] != DIMEN_ELEMENT
4535 && !(array_ref
->dimen_type
[dim
] == DIMEN_UNKNOWN
4536 && array_ref
->end
[dim
] == NULL
4537 && array_ref
->start
[dim
] != NULL
))
4541 rank
= a
->target
->rank
;
4542 /* When the rank is greater than zero then sym will be an array. */
4543 if (sym
->ts
.type
== BT_CLASS
)
4545 if ((!CLASS_DATA (sym
)->as
&& rank
!= 0)
4546 || (CLASS_DATA (sym
)->as
4547 && CLASS_DATA (sym
)->as
->rank
!= rank
))
4549 /* Don't just (re-)set the attr and as in the sym.ts,
4550 because this modifies the target's attr and as. Copy the
4551 data and do a build_class_symbol. */
4552 symbol_attribute attr
= CLASS_DATA (a
->target
)->attr
;
4553 int corank
= gfc_get_corank (a
->target
);
4558 as
= gfc_get_array_spec ();
4559 as
->type
= AS_DEFERRED
;
4561 as
->corank
= corank
;
4562 attr
.dimension
= rank
? 1 : 0;
4563 attr
.codimension
= corank
? 1 : 0;
4568 attr
.dimension
= attr
.codimension
= 0;
4571 type
= CLASS_DATA (sym
)->ts
;
4572 if (!gfc_build_class_symbol (&type
,
4576 sym
->ts
.type
= BT_CLASS
;
4577 sym
->attr
.class_ok
= 1;
4580 sym
->attr
.class_ok
= 1;
4582 else if ((!sym
->as
&& rank
!= 0)
4583 || (sym
->as
&& sym
->as
->rank
!= rank
))
4585 as
= gfc_get_array_spec ();
4586 as
->type
= AS_DEFERRED
;
4588 as
->corank
= gfc_get_corank (a
->target
);
4590 sym
->attr
.dimension
= 1;
4592 sym
->attr
.codimension
= 1;
4597 accept_statement (ST_ASSOCIATE
);
4598 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
4601 st
= parse_executable (ST_NONE
);
4608 accept_statement (st
);
4609 my_ns
->code
= gfc_state_stack
->head
;
4613 unexpected_statement (st
);
4617 gfc_current_ns
= gfc_current_ns
->parent
;
4622 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
4623 handled inside of parse_executable(), because they aren't really
4627 parse_do_block (void)
4636 s
.ext
.end_do_label
= new_st
.label1
;
4638 if (new_st
.ext
.iterator
!= NULL
)
4640 stree
= new_st
.ext
.iterator
->var
->symtree
;
4641 if (directive_unroll
!= -1)
4643 new_st
.ext
.iterator
->unroll
= directive_unroll
;
4644 directive_unroll
= -1;
4650 accept_statement (ST_DO
);
4652 top
= gfc_state_stack
->tail
;
4653 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
4656 s
.do_variable
= stree
;
4658 top
->block
= new_level (top
);
4659 top
->block
->op
= EXEC_DO
;
4662 st
= parse_executable (ST_NONE
);
4670 if (s
.ext
.end_do_label
!= NULL
4671 && s
.ext
.end_do_label
!= gfc_statement_label
)
4672 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
4675 if (gfc_statement_label
!= NULL
)
4677 new_st
.op
= EXEC_NOP
;
4682 case ST_IMPLIED_ENDDO
:
4683 /* If the do-stmt of this DO construct has a do-construct-name,
4684 the corresponding end-do must be an end-do-stmt (with a matching
4685 name, but in that case we must have seen ST_ENDDO first).
4686 We only complain about this in pedantic mode. */
4687 if (gfc_current_block () != NULL
)
4688 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
4689 &gfc_current_block()->declared_at
);
4694 unexpected_statement (st
);
4699 accept_statement (st
);
4703 /* Parse the statements of OpenMP do/parallel do. */
4705 static gfc_statement
4706 parse_omp_do (gfc_statement omp_st
)
4712 accept_statement (omp_st
);
4714 cp
= gfc_state_stack
->tail
;
4715 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4716 np
= new_level (cp
);
4722 st
= next_statement ();
4725 else if (st
== ST_DO
)
4728 unexpected_statement (st
);
4732 if (gfc_statement_label
!= NULL
4733 && gfc_state_stack
->previous
!= NULL
4734 && gfc_state_stack
->previous
->state
== COMP_DO
4735 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4743 there should be no !$OMP END DO. */
4745 return ST_IMPLIED_ENDDO
;
4748 check_do_closure ();
4751 st
= next_statement ();
4752 gfc_statement omp_end_st
= ST_OMP_END_DO
;
4755 case ST_OMP_DISTRIBUTE
: omp_end_st
= ST_OMP_END_DISTRIBUTE
; break;
4756 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4757 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4759 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4760 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4762 case ST_OMP_DISTRIBUTE_SIMD
:
4763 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4765 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
4766 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
4767 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
4768 case ST_OMP_PARALLEL_DO_SIMD
:
4769 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
4771 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
4772 case ST_OMP_TARGET_PARALLEL_DO
:
4773 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO
;
4775 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
4776 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO_SIMD
;
4778 case ST_OMP_TARGET_SIMD
: omp_end_st
= ST_OMP_END_TARGET_SIMD
; break;
4779 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4780 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4782 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4783 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4785 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4786 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4788 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4789 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4791 case ST_OMP_TASKLOOP
: omp_end_st
= ST_OMP_END_TASKLOOP
; break;
4792 case ST_OMP_TASKLOOP_SIMD
: omp_end_st
= ST_OMP_END_TASKLOOP_SIMD
; break;
4793 case ST_OMP_TEAMS_DISTRIBUTE
:
4794 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4796 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4797 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4799 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4800 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4802 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4803 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4805 default: gcc_unreachable ();
4807 if (st
== omp_end_st
)
4809 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
4810 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4812 gcc_assert (new_st
.op
== EXEC_NOP
);
4813 gfc_clear_new_st ();
4814 gfc_commit_symbols ();
4815 gfc_warning_check ();
4816 st
= next_statement ();
4822 /* Parse the statements of OpenMP atomic directive. */
4824 static gfc_statement
4825 parse_omp_oacc_atomic (bool omp_p
)
4827 gfc_statement st
, st_atomic
, st_end_atomic
;
4834 st_atomic
= ST_OMP_ATOMIC
;
4835 st_end_atomic
= ST_OMP_END_ATOMIC
;
4839 st_atomic
= ST_OACC_ATOMIC
;
4840 st_end_atomic
= ST_OACC_END_ATOMIC
;
4842 accept_statement (st_atomic
);
4844 cp
= gfc_state_stack
->tail
;
4845 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4846 np
= new_level (cp
);
4849 np
->ext
.omp_atomic
= cp
->ext
.omp_atomic
;
4850 count
= 1 + ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4851 == GFC_OMP_ATOMIC_CAPTURE
);
4855 st
= next_statement ();
4858 else if (st
== ST_ASSIGNMENT
)
4860 accept_statement (st
);
4864 unexpected_statement (st
);
4869 st
= next_statement ();
4870 if (st
== st_end_atomic
)
4872 gfc_clear_new_st ();
4873 gfc_commit_symbols ();
4874 gfc_warning_check ();
4875 st
= next_statement ();
4877 else if ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4878 == GFC_OMP_ATOMIC_CAPTURE
)
4879 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
4884 /* Parse the statements of an OpenACC structured block. */
4887 parse_oacc_structured_block (gfc_statement acc_st
)
4889 gfc_statement st
, acc_end_st
;
4891 gfc_state_data s
, *sd
;
4893 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4894 if (sd
->state
== COMP_CRITICAL
)
4895 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4897 accept_statement (acc_st
);
4899 cp
= gfc_state_stack
->tail
;
4900 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4901 np
= new_level (cp
);
4906 case ST_OACC_PARALLEL
:
4907 acc_end_st
= ST_OACC_END_PARALLEL
;
4909 case ST_OACC_KERNELS
:
4910 acc_end_st
= ST_OACC_END_KERNELS
;
4913 acc_end_st
= ST_OACC_END_DATA
;
4915 case ST_OACC_HOST_DATA
:
4916 acc_end_st
= ST_OACC_END_HOST_DATA
;
4924 st
= parse_executable (ST_NONE
);
4927 else if (st
!= acc_end_st
)
4929 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
4930 reject_statement ();
4933 while (st
!= acc_end_st
);
4935 gcc_assert (new_st
.op
== EXEC_NOP
);
4937 gfc_clear_new_st ();
4938 gfc_commit_symbols ();
4939 gfc_warning_check ();
4943 /* Parse the statements of OpenACC loop/parallel loop/kernels loop. */
4945 static gfc_statement
4946 parse_oacc_loop (gfc_statement acc_st
)
4950 gfc_state_data s
, *sd
;
4952 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4953 if (sd
->state
== COMP_CRITICAL
)
4954 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4956 accept_statement (acc_st
);
4958 cp
= gfc_state_stack
->tail
;
4959 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4960 np
= new_level (cp
);
4966 st
= next_statement ();
4969 else if (st
== ST_DO
)
4973 gfc_error ("Expected DO loop at %C");
4974 reject_statement ();
4979 if (gfc_statement_label
!= NULL
4980 && gfc_state_stack
->previous
!= NULL
4981 && gfc_state_stack
->previous
->state
== COMP_DO
4982 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4985 return ST_IMPLIED_ENDDO
;
4988 check_do_closure ();
4991 st
= next_statement ();
4992 if (st
== ST_OACC_END_LOOP
)
4993 gfc_warning (0, "Redundant !$ACC END LOOP at %C");
4994 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
4995 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
4996 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
4998 gcc_assert (new_st
.op
== EXEC_NOP
);
4999 gfc_clear_new_st ();
5000 gfc_commit_symbols ();
5001 gfc_warning_check ();
5002 st
= next_statement ();
5008 /* Parse the statements of an OpenMP structured block. */
5011 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
5013 gfc_statement st
, omp_end_st
;
5017 accept_statement (omp_st
);
5019 cp
= gfc_state_stack
->tail
;
5020 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5021 np
= new_level (cp
);
5027 case ST_OMP_PARALLEL
:
5028 omp_end_st
= ST_OMP_END_PARALLEL
;
5030 case ST_OMP_PARALLEL_SECTIONS
:
5031 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
5033 case ST_OMP_SECTIONS
:
5034 omp_end_st
= ST_OMP_END_SECTIONS
;
5036 case ST_OMP_ORDERED
:
5037 omp_end_st
= ST_OMP_END_ORDERED
;
5039 case ST_OMP_CRITICAL
:
5040 omp_end_st
= ST_OMP_END_CRITICAL
;
5043 omp_end_st
= ST_OMP_END_MASTER
;
5046 omp_end_st
= ST_OMP_END_SINGLE
;
5049 omp_end_st
= ST_OMP_END_TARGET
;
5051 case ST_OMP_TARGET_DATA
:
5052 omp_end_st
= ST_OMP_END_TARGET_DATA
;
5054 case ST_OMP_TARGET_TEAMS
:
5055 omp_end_st
= ST_OMP_END_TARGET_TEAMS
;
5057 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5058 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
5060 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5061 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5063 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5064 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5066 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5067 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
5070 omp_end_st
= ST_OMP_END_TASK
;
5072 case ST_OMP_TASKGROUP
:
5073 omp_end_st
= ST_OMP_END_TASKGROUP
;
5076 omp_end_st
= ST_OMP_END_TEAMS
;
5078 case ST_OMP_TEAMS_DISTRIBUTE
:
5079 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
5081 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5082 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5084 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5085 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5087 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5088 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
5090 case ST_OMP_DISTRIBUTE
:
5091 omp_end_st
= ST_OMP_END_DISTRIBUTE
;
5093 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5094 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
5096 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5097 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
5099 case ST_OMP_DISTRIBUTE_SIMD
:
5100 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
5102 case ST_OMP_WORKSHARE
:
5103 omp_end_st
= ST_OMP_END_WORKSHARE
;
5105 case ST_OMP_PARALLEL_WORKSHARE
:
5106 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
5114 if (workshare_stmts_only
)
5116 /* Inside of !$omp workshare, only
5119 where statements and constructs
5120 forall statements and constructs
5124 are allowed. For !$omp critical these
5125 restrictions apply recursively. */
5128 st
= next_statement ();
5139 accept_statement (st
);
5142 case ST_WHERE_BLOCK
:
5143 parse_where_block ();
5146 case ST_FORALL_BLOCK
:
5147 parse_forall_block ();
5150 case ST_OMP_PARALLEL
:
5151 case ST_OMP_PARALLEL_SECTIONS
:
5152 parse_omp_structured_block (st
, false);
5155 case ST_OMP_PARALLEL_WORKSHARE
:
5156 case ST_OMP_CRITICAL
:
5157 parse_omp_structured_block (st
, true);
5160 case ST_OMP_PARALLEL_DO
:
5161 case ST_OMP_PARALLEL_DO_SIMD
:
5162 st
= parse_omp_do (st
);
5166 st
= parse_omp_oacc_atomic (true);
5177 st
= next_statement ();
5181 st
= parse_executable (ST_NONE
);
5184 else if (st
== ST_OMP_SECTION
5185 && (omp_st
== ST_OMP_SECTIONS
5186 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
5188 np
= new_level (np
);
5192 else if (st
!= omp_end_st
)
5193 unexpected_statement (st
);
5195 while (st
!= omp_end_st
);
5199 case EXEC_OMP_END_NOWAIT
:
5200 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
5202 case EXEC_OMP_END_CRITICAL
:
5203 if (((cp
->ext
.omp_clauses
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
5204 || (new_st
.ext
.omp_name
!= NULL
5205 && strcmp (cp
->ext
.omp_clauses
->critical_name
,
5206 new_st
.ext
.omp_name
) != 0))
5207 gfc_error ("Name after !$omp critical and !$omp end critical does "
5209 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
5210 new_st
.ext
.omp_name
= NULL
;
5212 case EXEC_OMP_END_SINGLE
:
5213 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
5214 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
5215 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
5216 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
5224 gfc_clear_new_st ();
5225 gfc_commit_symbols ();
5226 gfc_warning_check ();
5231 /* Accept a series of executable statements. We return the first
5232 statement that doesn't fit to the caller. Any block statements are
5233 passed on to the correct handler, which usually passes the buck
5236 static gfc_statement
5237 parse_executable (gfc_statement st
)
5242 st
= next_statement ();
5246 close_flag
= check_do_closure ();
5251 case ST_END_PROGRAM
:
5254 case ST_END_FUNCTION
:
5259 case ST_END_SUBROUTINE
:
5264 case ST_SELECT_CASE
:
5265 gfc_error ("%s statement at %C cannot terminate a non-block "
5266 "DO loop", gfc_ascii_statement (st
));
5279 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
5280 "first executable statement");
5286 accept_statement (st
);
5287 if (close_flag
== 1)
5288 return ST_IMPLIED_ENDDO
;
5292 parse_block_construct ();
5303 case ST_SELECT_CASE
:
5304 parse_select_block ();
5307 case ST_SELECT_TYPE
:
5308 parse_select_type_block ();
5313 if (check_do_closure () == 1)
5314 return ST_IMPLIED_ENDDO
;
5318 parse_critical_block ();
5321 case ST_WHERE_BLOCK
:
5322 parse_where_block ();
5325 case ST_FORALL_BLOCK
:
5326 parse_forall_block ();
5329 case ST_OACC_PARALLEL_LOOP
:
5330 case ST_OACC_KERNELS_LOOP
:
5332 st
= parse_oacc_loop (st
);
5333 if (st
== ST_IMPLIED_ENDDO
)
5337 case ST_OACC_PARALLEL
:
5338 case ST_OACC_KERNELS
:
5340 case ST_OACC_HOST_DATA
:
5341 parse_oacc_structured_block (st
);
5344 case ST_OMP_PARALLEL
:
5345 case ST_OMP_PARALLEL_SECTIONS
:
5346 case ST_OMP_SECTIONS
:
5347 case ST_OMP_ORDERED
:
5348 case ST_OMP_CRITICAL
:
5352 case ST_OMP_TARGET_DATA
:
5353 case ST_OMP_TARGET_PARALLEL
:
5354 case ST_OMP_TARGET_TEAMS
:
5357 case ST_OMP_TASKGROUP
:
5358 parse_omp_structured_block (st
, false);
5361 case ST_OMP_WORKSHARE
:
5362 case ST_OMP_PARALLEL_WORKSHARE
:
5363 parse_omp_structured_block (st
, true);
5366 case ST_OMP_DISTRIBUTE
:
5367 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5368 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5369 case ST_OMP_DISTRIBUTE_SIMD
:
5371 case ST_OMP_DO_SIMD
:
5372 case ST_OMP_PARALLEL_DO
:
5373 case ST_OMP_PARALLEL_DO_SIMD
:
5375 case ST_OMP_TARGET_PARALLEL_DO
:
5376 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
5377 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5378 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5379 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5380 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5381 case ST_OMP_TASKLOOP
:
5382 case ST_OMP_TASKLOOP_SIMD
:
5383 case ST_OMP_TEAMS_DISTRIBUTE
:
5384 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5385 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5386 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5387 st
= parse_omp_do (st
);
5388 if (st
== ST_IMPLIED_ENDDO
)
5392 case ST_OACC_ATOMIC
:
5393 st
= parse_omp_oacc_atomic (false);
5397 st
= parse_omp_oacc_atomic (true);
5404 if (directive_unroll
!= -1)
5405 gfc_error ("%<GCC unroll%> directive does not commence a loop at %C");
5407 st
= next_statement ();
5412 /* Fix the symbols for sibling functions. These are incorrectly added to
5413 the child namespace as the parser didn't know about this procedure. */
5416 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
5420 gfc_symbol
*old_sym
;
5422 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
5424 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
5426 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
5427 goto fixup_contained
;
5429 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
5430 && sym
->attr
.generic
&& sym
->attr
.function
)
5431 ||(sym
->attr
.flavor
== FL_DERIVED
5432 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
5433 goto fixup_contained
;
5435 old_sym
= st
->n
.sym
;
5436 if (old_sym
->ns
== ns
5437 && !old_sym
->attr
.contained
5439 /* By 14.6.1.3, host association should be excluded
5440 for the following. */
5441 && !(old_sym
->attr
.external
5442 || (old_sym
->ts
.type
!= BT_UNKNOWN
5443 && !old_sym
->attr
.implicit_type
)
5444 || old_sym
->attr
.flavor
== FL_PARAMETER
5445 || old_sym
->attr
.use_assoc
5446 || old_sym
->attr
.in_common
5447 || old_sym
->attr
.in_equivalence
5448 || old_sym
->attr
.data
5449 || old_sym
->attr
.dummy
5450 || old_sym
->attr
.result
5451 || old_sym
->attr
.dimension
5452 || old_sym
->attr
.allocatable
5453 || old_sym
->attr
.intrinsic
5454 || old_sym
->attr
.generic
5455 || old_sym
->attr
.flavor
== FL_NAMELIST
5456 || old_sym
->attr
.flavor
== FL_LABEL
5457 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
5459 /* Replace it with the symbol from the parent namespace. */
5463 gfc_release_symbol (old_sym
);
5467 /* Do the same for any contained procedures. */
5468 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
5473 parse_contained (int module
)
5475 gfc_namespace
*ns
, *parent_ns
, *tmp
;
5476 gfc_state_data s1
, s2
;
5481 int contains_statements
= 0;
5484 push_state (&s1
, COMP_CONTAINS
, NULL
);
5485 parent_ns
= gfc_current_ns
;
5489 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
5491 gfc_current_ns
->sibling
= parent_ns
->contained
;
5492 parent_ns
->contained
= gfc_current_ns
;
5495 /* Process the next available statement. We come here if we got an error
5496 and rejected the last statement. */
5497 old_loc
= gfc_current_locus
;
5498 st
= next_statement ();
5507 contains_statements
= 1;
5508 accept_statement (st
);
5511 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
5514 /* For internal procedures, create/update the symbol in the
5515 parent namespace. */
5519 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
5520 gfc_error ("Contained procedure %qs at %C is already "
5521 "ambiguous", gfc_new_block
->name
);
5524 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
5526 &gfc_new_block
->declared_at
))
5528 if (st
== ST_FUNCTION
)
5529 gfc_add_function (&sym
->attr
, sym
->name
,
5530 &gfc_new_block
->declared_at
);
5532 gfc_add_subroutine (&sym
->attr
, sym
->name
,
5533 &gfc_new_block
->declared_at
);
5537 gfc_commit_symbols ();
5540 sym
= gfc_new_block
;
5542 /* Mark this as a contained function, so it isn't replaced
5543 by other module functions. */
5544 sym
->attr
.contained
= 1;
5546 /* Set implicit_pure so that it can be reset if any of the
5547 tests for purity fail. This is used for some optimisation
5548 during translation. */
5549 if (!sym
->attr
.pure
)
5550 sym
->attr
.implicit_pure
= 1;
5552 parse_progunit (ST_NONE
);
5554 /* Fix up any sibling functions that refer to this one. */
5555 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
5556 /* Or refer to any of its alternate entry points. */
5557 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
5558 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
5560 gfc_current_ns
->code
= s2
.head
;
5561 gfc_current_ns
= parent_ns
;
5566 /* These statements are associated with the end of the host unit. */
5567 case ST_END_FUNCTION
:
5569 case ST_END_SUBMODULE
:
5570 case ST_END_PROGRAM
:
5571 case ST_END_SUBROUTINE
:
5572 accept_statement (st
);
5573 gfc_current_ns
->code
= s1
.head
;
5577 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
5578 gfc_ascii_statement (st
));
5579 reject_statement ();
5585 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
5586 && st
!= ST_END_MODULE
&& st
!= ST_END_SUBMODULE
5587 && st
!= ST_END_PROGRAM
);
5589 /* The first namespace in the list is guaranteed to not have
5590 anything (worthwhile) in it. */
5591 tmp
= gfc_current_ns
;
5592 gfc_current_ns
= parent_ns
;
5593 if (seen_error
&& tmp
->refs
> 1)
5594 gfc_free_namespace (tmp
);
5596 ns
= gfc_current_ns
->contained
;
5597 gfc_current_ns
->contained
= ns
->sibling
;
5598 gfc_free_namespace (ns
);
5601 if (!contains_statements
)
5602 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
5603 "FUNCTION or SUBROUTINE statement at %L", &old_loc
);
5607 /* The result variable in a MODULE PROCEDURE needs to be created and
5608 its characteristics copied from the interface since it is neither
5609 declared in the procedure declaration nor in the specification
5613 get_modproc_result (void)
5616 if (gfc_state_stack
->previous
5617 && gfc_state_stack
->previous
->state
== COMP_CONTAINS
5618 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
5620 proc
= gfc_current_ns
->proc_name
? gfc_current_ns
->proc_name
: NULL
;
5622 && proc
->attr
.function
5624 && proc
->tlink
->result
5625 && proc
->tlink
->result
!= proc
->tlink
)
5627 gfc_copy_dummy_sym (&proc
->result
, proc
->tlink
->result
, 1);
5628 gfc_set_sym_referenced (proc
->result
);
5629 proc
->result
->attr
.if_source
= IFSRC_DECL
;
5630 gfc_commit_symbol (proc
->result
);
5636 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
5639 parse_progunit (gfc_statement st
)
5645 && gfc_new_block
->abr_modproc_decl
5646 && gfc_new_block
->attr
.function
)
5647 get_modproc_result ();
5649 st
= parse_spec (st
);
5656 /* This is not allowed within BLOCK! */
5657 if (gfc_current_state () != COMP_BLOCK
)
5662 accept_statement (st
);
5669 if (gfc_current_state () == COMP_FUNCTION
)
5670 gfc_check_function_type (gfc_current_ns
);
5675 st
= parse_executable (st
);
5683 /* This is not allowed within BLOCK! */
5684 if (gfc_current_state () != COMP_BLOCK
)
5689 accept_statement (st
);
5696 unexpected_statement (st
);
5697 reject_statement ();
5698 st
= next_statement ();
5704 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
5705 if (p
->state
== COMP_CONTAINS
)
5708 if (gfc_find_state (COMP_MODULE
) == true
5709 || gfc_find_state (COMP_SUBMODULE
) == true)
5714 gfc_error ("CONTAINS statement at %C is already in a contained "
5716 reject_statement ();
5717 st
= next_statement ();
5721 parse_contained (0);
5724 gfc_current_ns
->code
= gfc_state_stack
->head
;
5728 /* Come here to complain about a global symbol already in use as
5732 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
5737 where
= &gfc_current_locus
;
5747 case GSYM_SUBROUTINE
:
5748 name
= "SUBROUTINE";
5753 case GSYM_BLOCK_DATA
:
5754 name
= "BLOCK DATA";
5765 if (sym
->binding_label
)
5766 gfc_error ("Global binding name %qs at %L is already being used "
5767 "as a %s at %L", sym
->binding_label
, where
, name
,
5770 gfc_error ("Global name %qs at %L is already being used as "
5771 "a %s at %L", sym
->name
, where
, name
, &sym
->where
);
5775 if (sym
->binding_label
)
5776 gfc_error ("Global binding name %qs at %L is already being used "
5777 "at %L", sym
->binding_label
, where
, &sym
->where
);
5779 gfc_error ("Global name %qs at %L is already being used at %L",
5780 sym
->name
, where
, &sym
->where
);
5785 /* Parse a block data program unit. */
5788 parse_block_data (void)
5791 static locus blank_locus
;
5792 static int blank_block
=0;
5795 gfc_current_ns
->proc_name
= gfc_new_block
;
5796 gfc_current_ns
->is_block_data
= 1;
5798 if (gfc_new_block
== NULL
)
5801 gfc_error ("Blank BLOCK DATA at %C conflicts with "
5802 "prior BLOCK DATA at %L", &blank_locus
);
5806 blank_locus
= gfc_current_locus
;
5811 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5813 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
5814 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5817 s
->type
= GSYM_BLOCK_DATA
;
5818 s
->where
= gfc_new_block
->declared_at
;
5823 st
= parse_spec (ST_NONE
);
5825 while (st
!= ST_END_BLOCK_DATA
)
5827 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
5828 gfc_ascii_statement (st
));
5829 reject_statement ();
5830 st
= next_statement ();
5835 /* Following the association of the ancestor (sub)module symbols, they
5836 must be set host rather than use associated and all must be public.
5837 They are flagged up by 'used_in_submodule' so that they can be set
5838 DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
5839 linker chokes on multiple symbol definitions. */
5842 set_syms_host_assoc (gfc_symbol
*sym
)
5845 const char dot
[2] = ".";
5846 char parent1
[GFC_MAX_SYMBOL_LEN
+ 1];
5847 char parent2
[GFC_MAX_SYMBOL_LEN
+ 1];
5852 if (sym
->attr
.module_procedure
)
5853 sym
->attr
.external
= 0;
5855 sym
->attr
.use_assoc
= 0;
5856 sym
->attr
.host_assoc
= 1;
5857 sym
->attr
.used_in_submodule
=1;
5859 if (sym
->attr
.flavor
== FL_DERIVED
)
5861 /* Derived types with PRIVATE components that are declared in
5862 modules other than the parent module must not be changed to be
5863 PUBLIC. The 'use-assoc' attribute must be reset so that the
5864 test in symbol.c(gfc_find_component) works correctly. This is
5865 not necessary for PRIVATE symbols since they are not read from
5867 memset(parent1
, '\0', sizeof(parent1
));
5868 memset(parent2
, '\0', sizeof(parent2
));
5869 strcpy (parent1
, gfc_new_block
->name
);
5870 strcpy (parent2
, sym
->module
);
5871 if (strcmp (strtok (parent1
, dot
), strtok (parent2
, dot
)) == 0)
5873 for (c
= sym
->components
; c
; c
= c
->next
)
5874 c
->attr
.access
= ACCESS_PUBLIC
;
5878 sym
->attr
.use_assoc
= 1;
5879 sym
->attr
.host_assoc
= 0;
5884 /* Parse a module subprogram. */
5893 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5894 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
5895 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5898 s
->type
= GSYM_MODULE
;
5899 s
->where
= gfc_new_block
->declared_at
;
5903 /* Something is nulling the module_list after this point. This is good
5904 since it allows us to 'USE' the parent modules that the submodule
5905 inherits and to set (most) of the symbols as host associated. */
5906 if (gfc_current_state () == COMP_SUBMODULE
)
5909 gfc_traverse_ns (gfc_current_ns
, set_syms_host_assoc
);
5912 st
= parse_spec (ST_NONE
);
5922 parse_contained (1);
5926 case ST_END_SUBMODULE
:
5927 accept_statement (st
);
5931 gfc_error ("Unexpected %s statement in MODULE at %C",
5932 gfc_ascii_statement (st
));
5935 reject_statement ();
5936 st
= next_statement ();
5940 /* Make sure not to free the namespace twice on error. */
5942 s
->ns
= gfc_current_ns
;
5946 /* Add a procedure name to the global symbol table. */
5949 add_global_procedure (bool sub
)
5953 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5954 name is a global identifier. */
5955 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5957 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5960 || (s
->type
!= GSYM_UNKNOWN
5961 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5963 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5964 /* Silence follow-up errors. */
5965 gfc_new_block
->binding_label
= NULL
;
5969 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5970 s
->sym_name
= gfc_new_block
->name
;
5971 s
->where
= gfc_new_block
->declared_at
;
5973 s
->ns
= gfc_current_ns
;
5977 /* Don't add the symbol multiple times. */
5978 if (gfc_new_block
->binding_label
5979 && (!gfc_notification_std (GFC_STD_F2008
)
5980 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
5982 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
);
5985 || (s
->type
!= GSYM_UNKNOWN
5986 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5988 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5989 /* Silence follow-up errors. */
5990 gfc_new_block
->binding_label
= NULL
;
5994 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5995 s
->sym_name
= gfc_new_block
->name
;
5996 s
->binding_label
= gfc_new_block
->binding_label
;
5997 s
->where
= gfc_new_block
->declared_at
;
5999 s
->ns
= gfc_current_ns
;
6005 /* Add a program to the global symbol table. */
6008 add_global_program (void)
6012 if (gfc_new_block
== NULL
)
6014 s
= gfc_get_gsymbol (gfc_new_block
->name
);
6016 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
6017 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6020 s
->type
= GSYM_PROGRAM
;
6021 s
->where
= gfc_new_block
->declared_at
;
6023 s
->ns
= gfc_current_ns
;
6028 /* Resolve all the program units. */
6030 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
6032 gfc_free_dt_list ();
6033 gfc_current_ns
= gfc_global_ns_list
;
6034 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6036 if (gfc_current_ns
->proc_name
6037 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6038 continue; /* Already resolved. */
6040 if (gfc_current_ns
->proc_name
)
6041 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6042 gfc_resolve (gfc_current_ns
);
6043 gfc_current_ns
->derived_types
= gfc_derived_types
;
6044 gfc_derived_types
= NULL
;
6050 clean_up_modules (gfc_gsymbol
*gsym
)
6055 clean_up_modules (gsym
->left
);
6056 clean_up_modules (gsym
->right
);
6058 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
6061 gfc_current_ns
= gsym
->ns
;
6062 gfc_derived_types
= gfc_current_ns
->derived_types
;
6069 /* Translate all the program units. This could be in a different order
6070 to resolution if there are forward references in the file. */
6072 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
6076 gfc_current_ns
= gfc_global_ns_list
;
6077 gfc_get_errors (NULL
, &errors
);
6079 /* We first translate all modules to make sure that later parts
6080 of the program can use the decl. Then we translate the nonmodules. */
6082 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6084 if (!gfc_current_ns
->proc_name
6085 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6088 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6089 gfc_derived_types
= gfc_current_ns
->derived_types
;
6090 gfc_generate_module_code (gfc_current_ns
);
6091 gfc_current_ns
->translated
= 1;
6094 gfc_current_ns
= gfc_global_ns_list
;
6095 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6097 if (gfc_current_ns
->proc_name
6098 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6101 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6102 gfc_derived_types
= gfc_current_ns
->derived_types
;
6103 gfc_generate_code (gfc_current_ns
);
6104 gfc_current_ns
->translated
= 1;
6107 /* Clean up all the namespaces after translation. */
6108 gfc_current_ns
= gfc_global_ns_list
;
6109 for (;gfc_current_ns
;)
6113 if (gfc_current_ns
->proc_name
6114 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6116 gfc_current_ns
= gfc_current_ns
->sibling
;
6120 ns
= gfc_current_ns
->sibling
;
6121 gfc_derived_types
= gfc_current_ns
->derived_types
;
6123 gfc_current_ns
= ns
;
6126 clean_up_modules (gfc_gsym_root
);
6130 /* Top level parser. */
6133 gfc_parse_file (void)
6135 int seen_program
, errors_before
, errors
;
6136 gfc_state_data top
, s
;
6139 gfc_namespace
*next
;
6141 gfc_start_source_files ();
6143 top
.state
= COMP_NONE
;
6145 top
.previous
= NULL
;
6146 top
.head
= top
.tail
= NULL
;
6147 top
.do_variable
= NULL
;
6149 gfc_state_stack
= &top
;
6151 gfc_clear_new_st ();
6153 gfc_statement_label
= NULL
;
6155 if (setjmp (eof_buf
))
6156 return false; /* Come here on unexpected EOF */
6158 /* Prepare the global namespace that will contain the
6160 gfc_global_ns_list
= next
= NULL
;
6165 /* Exit early for empty files. */
6169 in_specification_block
= true;
6172 st
= next_statement ();
6181 goto duplicate_main
;
6183 prog_locus
= gfc_current_locus
;
6185 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
6186 main_program_symbol (gfc_current_ns
, gfc_new_block
->name
);
6187 accept_statement (st
);
6188 add_global_program ();
6189 parse_progunit (ST_NONE
);
6193 add_global_procedure (true);
6194 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
6195 accept_statement (st
);
6196 parse_progunit (ST_NONE
);
6200 add_global_procedure (false);
6201 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
6202 accept_statement (st
);
6203 parse_progunit (ST_NONE
);
6207 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
6208 accept_statement (st
);
6209 parse_block_data ();
6213 push_state (&s
, COMP_MODULE
, gfc_new_block
);
6214 accept_statement (st
);
6216 gfc_get_errors (NULL
, &errors_before
);
6221 push_state (&s
, COMP_SUBMODULE
, gfc_new_block
);
6222 accept_statement (st
);
6224 gfc_get_errors (NULL
, &errors_before
);
6228 /* Anything else starts a nameless main program block. */
6231 goto duplicate_main
;
6233 prog_locus
= gfc_current_locus
;
6235 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
6236 main_program_symbol (gfc_current_ns
, "MAIN__");
6237 parse_progunit (st
);
6241 /* Handle the non-program units. */
6242 gfc_current_ns
->code
= s
.head
;
6244 gfc_resolve (gfc_current_ns
);
6246 /* Dump the parse tree if requested. */
6247 if (flag_dump_fortran_original
)
6248 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6250 if (flag_c_prototypes
)
6251 gfc_dump_c_prototypes (gfc_current_ns
, stdout
);
6253 gfc_get_errors (NULL
, &errors
);
6254 if (s
.state
== COMP_MODULE
|| s
.state
== COMP_SUBMODULE
)
6256 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
6257 gfc_current_ns
->derived_types
= gfc_derived_types
;
6258 gfc_derived_types
= NULL
;
6264 gfc_generate_code (gfc_current_ns
);
6272 /* The main program and non-contained procedures are put
6273 in the global namespace list, so that they can be processed
6274 later and all their interfaces resolved. */
6275 gfc_current_ns
->code
= s
.head
;
6278 for (; next
->sibling
; next
= next
->sibling
)
6280 next
->sibling
= gfc_current_ns
;
6283 gfc_global_ns_list
= gfc_current_ns
;
6285 next
= gfc_current_ns
;
6291 /* Do the resolution. */
6292 resolve_all_program_units (gfc_global_ns_list
);
6294 /* Do the parse tree dump. */
6295 gfc_current_ns
= flag_dump_fortran_original
? gfc_global_ns_list
: NULL
;
6297 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6298 if (!gfc_current_ns
->proc_name
6299 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6301 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6302 fputs ("------------------------------------------\n\n", stdout
);
6305 /* Do the translation. */
6306 translate_all_program_units (gfc_global_ns_list
);
6308 gfc_end_source_files ();
6312 /* If we see a duplicate main program, shut down. If the second
6313 instance is an implied main program, i.e. data decls or executable
6314 statements, we're in for lots of errors. */
6315 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
6316 reject_statement ();
6321 /* Return true if this state data represents an OpenACC region. */
6323 is_oacc (gfc_state_data
*sd
)
6325 switch (sd
->construct
->op
)
6327 case EXEC_OACC_PARALLEL_LOOP
:
6328 case EXEC_OACC_PARALLEL
:
6329 case EXEC_OACC_KERNELS_LOOP
:
6330 case EXEC_OACC_KERNELS
:
6331 case EXEC_OACC_DATA
:
6332 case EXEC_OACC_HOST_DATA
:
6333 case EXEC_OACC_LOOP
:
6334 case EXEC_OACC_UPDATE
:
6335 case EXEC_OACC_WAIT
:
6336 case EXEC_OACC_CACHE
:
6337 case EXEC_OACC_ENTER_DATA
:
6338 case EXEC_OACC_EXIT_DATA
:
6339 case EXEC_OACC_ATOMIC
:
6340 case EXEC_OACC_ROUTINE
: