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 ("change team", gfc_match_change_team
, ST_CHANGE_TEAM
);
455 match ("close", gfc_match_close
, ST_CLOSE
);
456 match ("continue", gfc_match_continue
, ST_CONTINUE
);
457 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
458 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
459 match ("case", gfc_match_case
, ST_CASE
);
460 match ("common", gfc_match_common
, ST_COMMON
);
461 match ("contains", gfc_match_eos
, ST_CONTAINS
);
462 match ("class", gfc_match_class_is
, ST_CLASS_IS
);
463 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
467 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
468 match ("data", gfc_match_data
, ST_DATA
);
469 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
473 match ("end file", gfc_match_endfile
, ST_END_FILE
);
474 match ("end team", gfc_match_end_team
, ST_END_TEAM
);
475 match ("exit", gfc_match_exit
, ST_EXIT
);
476 match ("else", gfc_match_else
, ST_ELSE
);
477 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
478 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
479 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
);
480 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
482 if (gfc_match_end (&st
) == MATCH_YES
)
485 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
486 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
487 match ("external", gfc_match_external
, ST_ATTR_DECL
);
488 match ("event post", gfc_match_event_post
, ST_EVENT_POST
);
489 match ("event wait", gfc_match_event_wait
, ST_EVENT_WAIT
);
493 match ("fail image", gfc_match_fail_image
, ST_FAIL_IMAGE
);
494 match ("final", gfc_match_final_decl
, ST_FINAL
);
495 match ("flush", gfc_match_flush
, ST_FLUSH
);
496 match ("form team", gfc_match_form_team
, ST_FORM_TEAM
);
497 match ("format", gfc_match_format
, ST_FORMAT
);
501 match ("generic", gfc_match_generic
, ST_GENERIC
);
502 match ("go to", gfc_match_goto
, ST_GOTO
);
506 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
507 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
508 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
509 match ("import", gfc_match_import
, ST_IMPORT
);
510 match ("interface", gfc_match_interface
, ST_INTERFACE
);
511 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
512 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
516 match ("lock", gfc_match_lock
, ST_LOCK
);
520 match ("map", gfc_match_map
, ST_MAP
);
521 match ("module% procedure", gfc_match_modproc
, ST_MODULE_PROC
);
522 match ("module", gfc_match_module
, ST_MODULE
);
526 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
527 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
531 match ("open", gfc_match_open
, ST_OPEN
);
532 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
536 match ("print", gfc_match_print
, ST_WRITE
);
537 match ("pause", gfc_match_pause
, ST_PAUSE
);
538 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
539 if (gfc_match_private (&st
) == MATCH_YES
)
541 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
542 match ("program", gfc_match_program
, ST_PROGRAM
);
543 if (gfc_match_public (&st
) == MATCH_YES
)
545 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
549 match ("read", gfc_match_read
, ST_READ
);
550 match ("return", gfc_match_return
, ST_RETURN
);
551 match ("rewind", gfc_match_rewind
, ST_REWIND
);
555 match ("structure", gfc_match_structure_decl
, ST_STRUCTURE_DECL
);
556 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
557 match ("stop", gfc_match_stop
, ST_STOP
);
558 match ("save", gfc_match_save
, ST_ATTR_DECL
);
559 match ("static", gfc_match_static
, ST_ATTR_DECL
);
560 match ("submodule", gfc_match_submodule
, ST_SUBMODULE
);
561 match ("sync all", gfc_match_sync_all
, ST_SYNC_ALL
);
562 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
563 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
564 match ("sync team", gfc_match_sync_team
, ST_SYNC_TEAM
);
568 match ("target", gfc_match_target
, ST_ATTR_DECL
);
569 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
570 match ("type is", gfc_match_type_is
, ST_TYPE_IS
);
574 match ("union", gfc_match_union
, ST_UNION
);
575 match ("unlock", gfc_match_unlock
, ST_UNLOCK
);
579 match ("value", gfc_match_value
, ST_ATTR_DECL
);
580 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
584 match ("wait", gfc_match_wait
, ST_WAIT
);
585 match ("write", gfc_match_write
, ST_WRITE
);
589 /* All else has failed, so give up. See if any of the matchers has
590 stored an error message of some sort. */
592 if (!gfc_error_check ())
593 gfc_error_now ("Unclassifiable statement at %C");
597 gfc_error_recovery ();
602 /* Like match and if spec_only, goto do_spec_only without actually
604 #define matcha(keyword, subr, st) \
606 if (spec_only && gfc_match (keyword) == MATCH_YES) \
608 else if (match_word (keyword, subr, &old_locus) \
612 undo_new_statement (); \
616 decode_oacc_directive (void)
620 bool spec_only
= false;
622 gfc_enforce_clean_symbol_state ();
624 gfc_clear_error (); /* Clear any pending errors. */
625 gfc_clear_warning (); /* Clear any pending warnings. */
629 gfc_error_now ("OpenACC directives at %C may not appear in PURE "
631 gfc_error_recovery ();
635 if (gfc_current_state () == COMP_FUNCTION
636 && gfc_current_block ()->result
->ts
.kind
== -1)
639 gfc_unset_implicit_pure (NULL
);
641 old_locus
= gfc_current_locus
;
643 /* General OpenACC directive matching: Instead of testing every possible
644 statement, we eliminate most possibilities by peeking at the
647 c
= gfc_peek_ascii_char ();
652 matcha ("atomic", gfc_match_oacc_atomic
, ST_OACC_ATOMIC
);
655 matcha ("cache", gfc_match_oacc_cache
, ST_OACC_CACHE
);
658 matcha ("data", gfc_match_oacc_data
, ST_OACC_DATA
);
659 match ("declare", gfc_match_oacc_declare
, ST_OACC_DECLARE
);
662 matcha ("end atomic", gfc_match_omp_eos
, ST_OACC_END_ATOMIC
);
663 matcha ("end data", gfc_match_omp_eos
, ST_OACC_END_DATA
);
664 matcha ("end host_data", gfc_match_omp_eos
, ST_OACC_END_HOST_DATA
);
665 matcha ("end kernels loop", gfc_match_omp_eos
, ST_OACC_END_KERNELS_LOOP
);
666 matcha ("end kernels", gfc_match_omp_eos
, ST_OACC_END_KERNELS
);
667 matcha ("end loop", gfc_match_omp_eos
, ST_OACC_END_LOOP
);
668 matcha ("end parallel loop", gfc_match_omp_eos
,
669 ST_OACC_END_PARALLEL_LOOP
);
670 matcha ("end parallel", gfc_match_omp_eos
, ST_OACC_END_PARALLEL
);
671 matcha ("enter data", gfc_match_oacc_enter_data
, ST_OACC_ENTER_DATA
);
672 matcha ("exit data", gfc_match_oacc_exit_data
, ST_OACC_EXIT_DATA
);
675 matcha ("host_data", gfc_match_oacc_host_data
, ST_OACC_HOST_DATA
);
678 matcha ("parallel loop", gfc_match_oacc_parallel_loop
,
679 ST_OACC_PARALLEL_LOOP
);
680 matcha ("parallel", gfc_match_oacc_parallel
, ST_OACC_PARALLEL
);
683 matcha ("kernels loop", gfc_match_oacc_kernels_loop
,
684 ST_OACC_KERNELS_LOOP
);
685 matcha ("kernels", gfc_match_oacc_kernels
, ST_OACC_KERNELS
);
688 matcha ("loop", gfc_match_oacc_loop
, ST_OACC_LOOP
);
691 match ("routine", gfc_match_oacc_routine
, ST_OACC_ROUTINE
);
694 matcha ("update", gfc_match_oacc_update
, ST_OACC_UPDATE
);
697 matcha ("wait", gfc_match_oacc_wait
, ST_OACC_WAIT
);
701 /* Directive not found or stored an error message.
702 Check and give up. */
704 if (gfc_error_check () == 0)
705 gfc_error_now ("Unclassifiable OpenACC directive at %C");
709 gfc_error_recovery ();
716 gfc_buffer_error (false);
717 gfc_current_locus
= old_locus
;
718 return ST_GET_FCN_CHARACTERISTICS
;
721 /* Like match, but set a flag simd_matched if keyword matched
722 and if spec_only, goto do_spec_only without actually matching. */
723 #define matchs(keyword, subr, st) \
725 if (spec_only && gfc_match (keyword) == MATCH_YES) \
727 if (match_word_omp_simd (keyword, subr, &old_locus, \
728 &simd_matched) == MATCH_YES) \
734 undo_new_statement (); \
737 /* Like match, but don't match anything if not -fopenmp
738 and if spec_only, goto do_spec_only without actually matching. */
739 #define matcho(keyword, subr, st) \
743 else if (spec_only && gfc_match (keyword) == MATCH_YES) \
745 else if (match_word (keyword, subr, &old_locus) \
752 undo_new_statement (); \
755 /* Like match, but set a flag simd_matched if keyword matched. */
756 #define matchds(keyword, subr, st) \
758 if (match_word_omp_simd (keyword, subr, &old_locus, \
759 &simd_matched) == MATCH_YES) \
765 undo_new_statement (); \
768 /* Like match, but don't match anything if not -fopenmp. */
769 #define matchdo(keyword, subr, st) \
773 else if (match_word (keyword, subr, &old_locus) \
780 undo_new_statement (); \
784 decode_omp_directive (void)
788 bool simd_matched
= false;
789 bool spec_only
= false;
790 gfc_statement ret
= ST_NONE
;
793 gfc_enforce_clean_symbol_state ();
795 gfc_clear_error (); /* Clear any pending errors. */
796 gfc_clear_warning (); /* Clear any pending warnings. */
798 if (gfc_current_state () == COMP_FUNCTION
799 && gfc_current_block ()->result
->ts
.kind
== -1)
802 old_locus
= gfc_current_locus
;
804 /* General OpenMP directive matching: Instead of testing every possible
805 statement, we eliminate most possibilities by peeking at the
808 c
= gfc_peek_ascii_char ();
810 /* match is for directives that should be recognized only if
811 -fopenmp, matchs for directives that should be recognized
812 if either -fopenmp or -fopenmp-simd.
813 Handle only the directives allowed in PURE/ELEMENTAL procedures
814 first (those also shall not turn off implicit pure). */
818 matchds ("declare simd", gfc_match_omp_declare_simd
,
819 ST_OMP_DECLARE_SIMD
);
820 matchdo ("declare target", gfc_match_omp_declare_target
,
821 ST_OMP_DECLARE_TARGET
);
824 matchs ("simd", gfc_match_omp_simd
, ST_OMP_SIMD
);
829 if (flag_openmp
&& gfc_pure (NULL
))
831 gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET "
832 "at %C may not appear in PURE or ELEMENTAL procedures");
833 gfc_error_recovery ();
837 /* match is for directives that should be recognized only if
838 -fopenmp, matchs for directives that should be recognized
839 if either -fopenmp or -fopenmp-simd. */
843 matcho ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
846 matcho ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
849 matcho ("cancellation% point", gfc_match_omp_cancellation_point
,
850 ST_OMP_CANCELLATION_POINT
);
851 matcho ("cancel", gfc_match_omp_cancel
, ST_OMP_CANCEL
);
852 matcho ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
855 matchds ("declare reduction", gfc_match_omp_declare_reduction
,
856 ST_OMP_DECLARE_REDUCTION
);
857 matchs ("distribute parallel do simd",
858 gfc_match_omp_distribute_parallel_do_simd
,
859 ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
);
860 matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do
,
861 ST_OMP_DISTRIBUTE_PARALLEL_DO
);
862 matchs ("distribute simd", gfc_match_omp_distribute_simd
,
863 ST_OMP_DISTRIBUTE_SIMD
);
864 matcho ("distribute", gfc_match_omp_distribute
, ST_OMP_DISTRIBUTE
);
865 matchs ("do simd", gfc_match_omp_do_simd
, ST_OMP_DO_SIMD
);
866 matcho ("do", gfc_match_omp_do
, ST_OMP_DO
);
869 matcho ("end atomic", gfc_match_omp_eos
, ST_OMP_END_ATOMIC
);
870 matcho ("end critical", gfc_match_omp_end_critical
, ST_OMP_END_CRITICAL
);
871 matchs ("end distribute parallel do simd", gfc_match_omp_eos
,
872 ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
);
873 matcho ("end distribute parallel do", gfc_match_omp_eos
,
874 ST_OMP_END_DISTRIBUTE_PARALLEL_DO
);
875 matchs ("end distribute simd", gfc_match_omp_eos
,
876 ST_OMP_END_DISTRIBUTE_SIMD
);
877 matcho ("end distribute", gfc_match_omp_eos
, ST_OMP_END_DISTRIBUTE
);
878 matchs ("end do simd", gfc_match_omp_end_nowait
, ST_OMP_END_DO_SIMD
);
879 matcho ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
880 matchs ("end simd", gfc_match_omp_eos
, ST_OMP_END_SIMD
);
881 matcho ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
882 matchs ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
883 matchs ("end parallel do simd", gfc_match_omp_eos
,
884 ST_OMP_END_PARALLEL_DO_SIMD
);
885 matcho ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
886 matcho ("end parallel sections", gfc_match_omp_eos
,
887 ST_OMP_END_PARALLEL_SECTIONS
);
888 matcho ("end parallel workshare", gfc_match_omp_eos
,
889 ST_OMP_END_PARALLEL_WORKSHARE
);
890 matcho ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
891 matcho ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
892 matcho ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
893 matcho ("end target data", gfc_match_omp_eos
, ST_OMP_END_TARGET_DATA
);
894 matchs ("end target parallel do simd", gfc_match_omp_eos
,
895 ST_OMP_END_TARGET_PARALLEL_DO_SIMD
);
896 matcho ("end target parallel do", gfc_match_omp_eos
,
897 ST_OMP_END_TARGET_PARALLEL_DO
);
898 matcho ("end target parallel", gfc_match_omp_eos
,
899 ST_OMP_END_TARGET_PARALLEL
);
900 matchs ("end target simd", gfc_match_omp_eos
, ST_OMP_END_TARGET_SIMD
);
901 matchs ("end target teams distribute parallel do simd",
903 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
904 matcho ("end target teams distribute parallel do", gfc_match_omp_eos
,
905 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
906 matchs ("end target teams distribute simd", gfc_match_omp_eos
,
907 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
);
908 matcho ("end target teams distribute", gfc_match_omp_eos
,
909 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
);
910 matcho ("end target teams", gfc_match_omp_eos
, ST_OMP_END_TARGET_TEAMS
);
911 matcho ("end target", gfc_match_omp_eos
, ST_OMP_END_TARGET
);
912 matcho ("end taskgroup", gfc_match_omp_eos
, ST_OMP_END_TASKGROUP
);
913 matchs ("end taskloop simd", gfc_match_omp_eos
,
914 ST_OMP_END_TASKLOOP_SIMD
);
915 matcho ("end taskloop", gfc_match_omp_eos
, ST_OMP_END_TASKLOOP
);
916 matcho ("end task", gfc_match_omp_eos
, ST_OMP_END_TASK
);
917 matchs ("end teams distribute parallel do simd", gfc_match_omp_eos
,
918 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
919 matcho ("end teams distribute parallel do", gfc_match_omp_eos
,
920 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
);
921 matchs ("end teams distribute simd", gfc_match_omp_eos
,
922 ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
);
923 matcho ("end teams distribute", gfc_match_omp_eos
,
924 ST_OMP_END_TEAMS_DISTRIBUTE
);
925 matcho ("end teams", gfc_match_omp_eos
, ST_OMP_END_TEAMS
);
926 matcho ("end workshare", gfc_match_omp_end_nowait
,
927 ST_OMP_END_WORKSHARE
);
930 matcho ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
933 matcho ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
936 if (gfc_match ("ordered depend (") == MATCH_YES
)
938 gfc_current_locus
= old_locus
;
941 matcho ("ordered", gfc_match_omp_ordered_depend
,
942 ST_OMP_ORDERED_DEPEND
);
945 matchs ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
948 matchs ("parallel do simd", gfc_match_omp_parallel_do_simd
,
949 ST_OMP_PARALLEL_DO_SIMD
);
950 matcho ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
951 matcho ("parallel sections", gfc_match_omp_parallel_sections
,
952 ST_OMP_PARALLEL_SECTIONS
);
953 matcho ("parallel workshare", gfc_match_omp_parallel_workshare
,
954 ST_OMP_PARALLEL_WORKSHARE
);
955 matcho ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
958 matcho ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
959 matcho ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
960 matcho ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
963 matcho ("target data", gfc_match_omp_target_data
, ST_OMP_TARGET_DATA
);
964 matcho ("target enter data", gfc_match_omp_target_enter_data
,
965 ST_OMP_TARGET_ENTER_DATA
);
966 matcho ("target exit data", gfc_match_omp_target_exit_data
,
967 ST_OMP_TARGET_EXIT_DATA
);
968 matchs ("target parallel do simd", gfc_match_omp_target_parallel_do_simd
,
969 ST_OMP_TARGET_PARALLEL_DO_SIMD
);
970 matcho ("target parallel do", gfc_match_omp_target_parallel_do
,
971 ST_OMP_TARGET_PARALLEL_DO
);
972 matcho ("target parallel", gfc_match_omp_target_parallel
,
973 ST_OMP_TARGET_PARALLEL
);
974 matchs ("target simd", gfc_match_omp_target_simd
, ST_OMP_TARGET_SIMD
);
975 matchs ("target teams distribute parallel do simd",
976 gfc_match_omp_target_teams_distribute_parallel_do_simd
,
977 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
978 matcho ("target teams distribute parallel do",
979 gfc_match_omp_target_teams_distribute_parallel_do
,
980 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
981 matchs ("target teams distribute simd",
982 gfc_match_omp_target_teams_distribute_simd
,
983 ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
);
984 matcho ("target teams distribute", gfc_match_omp_target_teams_distribute
,
985 ST_OMP_TARGET_TEAMS_DISTRIBUTE
);
986 matcho ("target teams", gfc_match_omp_target_teams
, ST_OMP_TARGET_TEAMS
);
987 matcho ("target update", gfc_match_omp_target_update
,
988 ST_OMP_TARGET_UPDATE
);
989 matcho ("target", gfc_match_omp_target
, ST_OMP_TARGET
);
990 matcho ("taskgroup", gfc_match_omp_taskgroup
, ST_OMP_TASKGROUP
);
991 matchs ("taskloop simd", gfc_match_omp_taskloop_simd
,
992 ST_OMP_TASKLOOP_SIMD
);
993 matcho ("taskloop", gfc_match_omp_taskloop
, ST_OMP_TASKLOOP
);
994 matcho ("taskwait", gfc_match_omp_taskwait
, ST_OMP_TASKWAIT
);
995 matcho ("taskyield", gfc_match_omp_taskyield
, ST_OMP_TASKYIELD
);
996 matcho ("task", gfc_match_omp_task
, ST_OMP_TASK
);
997 matchs ("teams distribute parallel do simd",
998 gfc_match_omp_teams_distribute_parallel_do_simd
,
999 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
1000 matcho ("teams distribute parallel do",
1001 gfc_match_omp_teams_distribute_parallel_do
,
1002 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
);
1003 matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd
,
1004 ST_OMP_TEAMS_DISTRIBUTE_SIMD
);
1005 matcho ("teams distribute", gfc_match_omp_teams_distribute
,
1006 ST_OMP_TEAMS_DISTRIBUTE
);
1007 matcho ("teams", gfc_match_omp_teams
, ST_OMP_TEAMS
);
1008 matchdo ("threadprivate", gfc_match_omp_threadprivate
,
1009 ST_OMP_THREADPRIVATE
);
1012 matcho ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
1016 /* All else has failed, so give up. See if any of the matchers has
1017 stored an error message of some sort. Don't error out if
1018 not -fopenmp and simd_matched is false, i.e. if a directive other
1019 than one marked with match has been seen. */
1021 if (flag_openmp
|| simd_matched
)
1023 if (!gfc_error_check ())
1024 gfc_error_now ("Unclassifiable OpenMP directive at %C");
1027 reject_statement ();
1029 gfc_error_recovery ();
1036 gfc_unset_implicit_pure (NULL
);
1038 if (!flag_openmp
&& gfc_pure (NULL
))
1040 gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET "
1041 "at %C may not appear in PURE or ELEMENTAL "
1043 reject_statement ();
1044 gfc_error_recovery ();
1051 reject_statement ();
1053 gfc_buffer_error (false);
1054 gfc_current_locus
= old_locus
;
1055 return ST_GET_FCN_CHARACTERISTICS
;
1058 static gfc_statement
1059 decode_gcc_attribute (void)
1063 gfc_enforce_clean_symbol_state ();
1065 gfc_clear_error (); /* Clear any pending errors. */
1066 gfc_clear_warning (); /* Clear any pending warnings. */
1067 old_locus
= gfc_current_locus
;
1069 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
1070 match ("unroll", gfc_match_gcc_unroll
, ST_NONE
);
1072 /* All else has failed, so give up. See if any of the matchers has
1073 stored an error message of some sort. */
1075 if (!gfc_error_check ())
1076 gfc_error_now ("Unclassifiable GCC directive at %C");
1078 reject_statement ();
1080 gfc_error_recovery ();
1087 /* Assert next length characters to be equal to token in free form. */
1090 verify_token_free (const char* token
, int length
, bool last_was_use_stmt
)
1095 c
= gfc_next_ascii_char ();
1096 for (i
= 0; i
< length
; i
++, c
= gfc_next_ascii_char ())
1097 gcc_assert (c
== token
[i
]);
1099 gcc_assert (gfc_is_whitespace(c
));
1100 gfc_gobble_whitespace ();
1101 if (last_was_use_stmt
)
1105 /* Get the next statement in free form source. */
1107 static gfc_statement
1114 at_bol
= gfc_at_bol ();
1115 gfc_gobble_whitespace ();
1117 c
= gfc_peek_ascii_char ();
1123 /* Found a statement label? */
1124 m
= gfc_match_st_label (&gfc_statement_label
);
1126 d
= gfc_peek_ascii_char ();
1127 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
1129 gfc_match_small_literal_int (&i
, &cnt
);
1132 gfc_error_now ("Too many digits in statement label at %C");
1135 gfc_error_now ("Zero is not a valid statement label at %C");
1138 c
= gfc_next_ascii_char ();
1141 if (!gfc_is_whitespace (c
))
1142 gfc_error_now ("Non-numeric character in statement label at %C");
1148 label_locus
= gfc_current_locus
;
1150 gfc_gobble_whitespace ();
1152 if (at_bol
&& gfc_peek_ascii_char () == ';')
1154 gfc_error_now ("Semicolon at %C needs to be preceded by "
1156 gfc_next_ascii_char (); /* Eat up the semicolon. */
1160 if (gfc_match_eos () == MATCH_YES
)
1161 gfc_error_now ("Statement label without statement at %L",
1167 /* Comments have already been skipped by the time we get here,
1168 except for GCC attributes and OpenMP/OpenACC directives. */
1170 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
1171 c
= gfc_peek_ascii_char ();
1177 c
= gfc_next_ascii_char ();
1178 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
1179 gcc_assert (c
== "gcc$"[i
]);
1181 gfc_gobble_whitespace ();
1182 return decode_gcc_attribute ();
1187 /* Since both OpenMP and OpenACC directives starts with
1188 !$ character sequence, we must check all flags combinations */
1189 if ((flag_openmp
|| flag_openmp_simd
)
1192 verify_token_free ("$omp", 4, last_was_use_stmt
);
1193 return decode_omp_directive ();
1195 else if ((flag_openmp
|| flag_openmp_simd
)
1198 gfc_next_ascii_char (); /* Eat up dollar character */
1199 c
= gfc_peek_ascii_char ();
1203 verify_token_free ("omp", 3, last_was_use_stmt
);
1204 return decode_omp_directive ();
1208 verify_token_free ("acc", 3, last_was_use_stmt
);
1209 return decode_oacc_directive ();
1212 else if (flag_openacc
)
1214 verify_token_free ("$acc", 4, last_was_use_stmt
);
1215 return decode_oacc_directive ();
1221 if (at_bol
&& c
== ';')
1223 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1224 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1226 gfc_next_ascii_char (); /* Eat up the semicolon. */
1230 return decode_statement ();
1233 /* Assert next length characters to be equal to token in fixed form. */
1236 verify_token_fixed (const char *token
, int length
, bool last_was_use_stmt
)
1239 char c
= gfc_next_char_literal (NONSTRING
);
1241 for (i
= 0; i
< length
; i
++, c
= gfc_next_char_literal (NONSTRING
))
1242 gcc_assert ((char) gfc_wide_tolower (c
) == token
[i
]);
1244 if (c
!= ' ' && c
!= '0')
1246 gfc_buffer_error (false);
1247 gfc_error ("Bad continuation line at %C");
1250 if (last_was_use_stmt
)
1256 /* Get the next statement in fixed-form source. */
1258 static gfc_statement
1261 int label
, digit_flag
, i
;
1266 return decode_statement ();
1268 /* Skip past the current label field, parsing a statement label if
1269 one is there. This is a weird number parser, since the number is
1270 contained within five columns and can have any kind of embedded
1271 spaces. We also check for characters that make the rest of the
1277 for (i
= 0; i
< 5; i
++)
1279 c
= gfc_next_char_literal (NONSTRING
);
1296 label
= label
* 10 + ((unsigned char) c
- '0');
1297 label_locus
= gfc_current_locus
;
1301 /* Comments have already been skipped by the time we get
1302 here, except for GCC attributes and OpenMP directives. */
1305 c
= gfc_next_char_literal (NONSTRING
);
1307 if (TOLOWER (c
) == 'g')
1309 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
1310 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
1312 return decode_gcc_attribute ();
1316 if ((flag_openmp
|| flag_openmp_simd
)
1319 if (!verify_token_fixed ("omp", 3, last_was_use_stmt
))
1321 return decode_omp_directive ();
1323 else if ((flag_openmp
|| flag_openmp_simd
)
1326 c
= gfc_next_char_literal(NONSTRING
);
1327 if (c
== 'o' || c
== 'O')
1329 if (!verify_token_fixed ("mp", 2, last_was_use_stmt
))
1331 return decode_omp_directive ();
1333 else if (c
== 'a' || c
== 'A')
1335 if (!verify_token_fixed ("cc", 2, last_was_use_stmt
))
1337 return decode_oacc_directive ();
1340 else if (flag_openacc
)
1342 if (!verify_token_fixed ("acc", 3, last_was_use_stmt
))
1344 return decode_oacc_directive ();
1349 /* Comments have already been skipped by the time we get
1350 here so don't bother checking for them. */
1353 gfc_buffer_error (false);
1354 gfc_error ("Non-numeric character in statement label at %C");
1362 gfc_warning_now (0, "Zero is not a valid statement label at %C");
1365 /* We've found a valid statement label. */
1366 gfc_statement_label
= gfc_get_st_label (label
);
1370 /* Since this line starts a statement, it cannot be a continuation
1371 of a previous statement. If we see something here besides a
1372 space or zero, it must be a bad continuation line. */
1374 c
= gfc_next_char_literal (NONSTRING
);
1378 if (c
!= ' ' && c
!= '0')
1380 gfc_buffer_error (false);
1381 gfc_error ("Bad continuation line at %C");
1385 /* Now that we've taken care of the statement label columns, we have
1386 to make sure that the first nonblank character is not a '!'. If
1387 it is, the rest of the line is a comment. */
1391 loc
= gfc_current_locus
;
1392 c
= gfc_next_char_literal (NONSTRING
);
1394 while (gfc_is_whitespace (c
));
1398 gfc_current_locus
= loc
;
1403 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1404 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1405 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1410 if (gfc_match_eos () == MATCH_YES
)
1413 /* At this point, we've got a nonblank statement to parse. */
1414 return decode_statement ();
1418 gfc_error_now ("Statement label without statement at %L", &label_locus
);
1420 gfc_current_locus
.lb
->truncated
= 0;
1421 gfc_advance_line ();
1426 /* Return the next non-ST_NONE statement to the caller. We also worry
1427 about including files and the ends of include files at this stage. */
1429 static gfc_statement
1430 next_statement (void)
1435 gfc_enforce_clean_symbol_state ();
1437 gfc_new_block
= NULL
;
1439 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1440 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
1443 gfc_statement_label
= NULL
;
1444 gfc_buffer_error (true);
1447 gfc_advance_line ();
1449 gfc_skip_comments ();
1457 if (gfc_define_undef_line ())
1460 old_locus
= gfc_current_locus
;
1462 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1468 gfc_buffer_error (false);
1470 if (st
== ST_GET_FCN_CHARACTERISTICS
)
1472 if (gfc_statement_label
!= NULL
)
1474 gfc_free_st_label (gfc_statement_label
);
1475 gfc_statement_label
= NULL
;
1477 gfc_current_locus
= old_locus
;
1481 check_statement_label (st
);
1487 /****************************** Parser ***********************************/
1489 /* The parser subroutines are of type 'try' that fail if the file ends
1492 /* Macros that expand to case-labels for various classes of
1493 statements. Start with executable statements that directly do
1496 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1497 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1498 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1499 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1500 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1501 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1502 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1503 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1504 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1505 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
1506 case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
1507 case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: \
1508 case ST_ERROR_STOP: case ST_SYNC_ALL: \
1509 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1510 case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
1511 case ST_END_TEAM: case ST_SYNC_TEAM: \
1512 case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
1513 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1514 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1516 /* Statements that mark other executable statements. */
1518 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1519 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1520 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1521 case ST_OMP_PARALLEL: \
1522 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1523 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
1524 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1525 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1526 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1527 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1528 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1529 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1530 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1531 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1532 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1533 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1534 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1535 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1536 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1537 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1538 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \
1539 case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \
1540 case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
1542 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1543 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
1544 case ST_OACC_KERNELS_LOOP: case ST_OACC_ATOMIC
1546 /* Declaration statements */
1548 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1549 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1550 case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE: case ST_OACC_ROUTINE: \
1551 case ST_OACC_DECLARE
1553 /* OpenMP declaration statements. */
1555 #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
1556 case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION
1558 /* Block end statements. Errors associated with interchanging these
1559 are detected in gfc_match_end(). */
1561 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1562 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1563 case ST_END_BLOCK: case ST_END_ASSOCIATE
1566 /* Push a new state onto the stack. */
1569 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1571 p
->state
= new_state
;
1572 p
->previous
= gfc_state_stack
;
1574 p
->head
= p
->tail
= NULL
;
1575 p
->do_variable
= NULL
;
1576 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1577 p
->ext
.oacc_declare_clauses
= NULL
;
1579 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1580 construct statement was accepted right before pushing the state. Thus,
1581 the construct's gfc_code is available as tail of the parent state. */
1582 gcc_assert (gfc_state_stack
);
1583 p
->construct
= gfc_state_stack
->tail
;
1585 gfc_state_stack
= p
;
1589 /* Pop the current state. */
1593 gfc_state_stack
= gfc_state_stack
->previous
;
1597 /* Try to find the given state in the state stack. */
1600 gfc_find_state (gfc_compile_state state
)
1604 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1605 if (p
->state
== state
)
1608 return (p
== NULL
) ? false : true;
1612 /* Starts a new level in the statement list. */
1615 new_level (gfc_code
*q
)
1619 p
= q
->block
= gfc_get_code (EXEC_NOP
);
1621 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1627 /* Add the current new_st code structure and adds it to the current
1628 program unit. As a side-effect, it zeroes the new_st. */
1631 add_statement (void)
1635 p
= XCNEW (gfc_code
);
1638 p
->loc
= gfc_current_locus
;
1640 if (gfc_state_stack
->head
== NULL
)
1641 gfc_state_stack
->head
= p
;
1643 gfc_state_stack
->tail
->next
= p
;
1645 while (p
->next
!= NULL
)
1648 gfc_state_stack
->tail
= p
;
1650 gfc_clear_new_st ();
1656 /* Frees everything associated with the current statement. */
1659 undo_new_statement (void)
1661 gfc_free_statements (new_st
.block
);
1662 gfc_free_statements (new_st
.next
);
1663 gfc_free_statement (&new_st
);
1664 gfc_clear_new_st ();
1668 /* If the current statement has a statement label, make sure that it
1669 is allowed to, or should have one. */
1672 check_statement_label (gfc_statement st
)
1676 if (gfc_statement_label
== NULL
)
1678 if (st
== ST_FORMAT
)
1679 gfc_error ("FORMAT statement at %L does not have a statement label",
1686 case ST_END_PROGRAM
:
1687 case ST_END_FUNCTION
:
1688 case ST_END_SUBROUTINE
:
1692 case ST_END_CRITICAL
:
1694 case ST_END_ASSOCIATE
:
1697 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
1698 type
= ST_LABEL_DO_TARGET
;
1700 type
= ST_LABEL_TARGET
;
1704 type
= ST_LABEL_FORMAT
;
1707 /* Statement labels are not restricted from appearing on a
1708 particular line. However, there are plenty of situations
1709 where the resulting label can't be referenced. */
1712 type
= ST_LABEL_BAD_TARGET
;
1716 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1718 new_st
.here
= gfc_statement_label
;
1722 /* Figures out what the enclosing program unit is. This will be a
1723 function, subroutine, program, block data or module. */
1726 gfc_enclosing_unit (gfc_compile_state
* result
)
1730 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1731 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1732 || p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
1733 || p
->state
== COMP_BLOCK_DATA
|| p
->state
== COMP_PROGRAM
)
1742 *result
= COMP_PROGRAM
;
1747 /* Translate a statement enum to a string. */
1750 gfc_ascii_statement (gfc_statement st
)
1756 case ST_ARITHMETIC_IF
:
1757 p
= _("arithmetic IF");
1766 p
= _("attribute declaration");
1802 p
= _("data declaration");
1816 case ST_STRUCTURE_DECL
:
1819 case ST_DERIVED_DECL
:
1820 p
= _("derived type declaration");
1843 case ST_CHANGE_TEAM
:
1855 case ST_END_ASSOCIATE
:
1856 p
= "END ASSOCIATE";
1861 case ST_END_BLOCK_DATA
:
1862 p
= "END BLOCK DATA";
1864 case ST_END_CRITICAL
:
1876 case ST_END_FUNCTION
:
1882 case ST_END_INTERFACE
:
1883 p
= "END INTERFACE";
1888 case ST_END_SUBMODULE
:
1889 p
= "END SUBMODULE";
1891 case ST_END_PROGRAM
:
1897 case ST_END_SUBROUTINE
:
1898 p
= "END SUBROUTINE";
1903 case ST_END_STRUCTURE
:
1904 p
= "END STRUCTURE";
1918 case ST_EQUIVALENCE
:
1930 case ST_FORALL_BLOCK
: /* Fall through */
1952 case ST_IMPLICIT_NONE
:
1953 p
= "IMPLICIT NONE";
1955 case ST_IMPLIED_ENDDO
:
1956 p
= _("implied END DO");
1988 case ST_MODULE_PROC
:
1989 p
= "MODULE PROCEDURE";
2021 case ST_SYNC_IMAGES
:
2024 case ST_SYNC_MEMORY
:
2039 case ST_WHERE_BLOCK
: /* Fall through */
2050 p
= _("assignment");
2052 case ST_POINTER_ASSIGNMENT
:
2053 p
= _("pointer assignment");
2055 case ST_SELECT_CASE
:
2058 case ST_SELECT_TYPE
:
2073 case ST_STATEMENT_FUNCTION
:
2074 p
= "STATEMENT FUNCTION";
2076 case ST_LABEL_ASSIGNMENT
:
2077 p
= "LABEL ASSIGNMENT";
2080 p
= "ENUM DEFINITION";
2083 p
= "ENUMERATOR DEFINITION";
2088 case ST_OACC_PARALLEL_LOOP
:
2089 p
= "!$ACC PARALLEL LOOP";
2091 case ST_OACC_END_PARALLEL_LOOP
:
2092 p
= "!$ACC END PARALLEL LOOP";
2094 case ST_OACC_PARALLEL
:
2095 p
= "!$ACC PARALLEL";
2097 case ST_OACC_END_PARALLEL
:
2098 p
= "!$ACC END PARALLEL";
2100 case ST_OACC_KERNELS
:
2101 p
= "!$ACC KERNELS";
2103 case ST_OACC_END_KERNELS
:
2104 p
= "!$ACC END KERNELS";
2106 case ST_OACC_KERNELS_LOOP
:
2107 p
= "!$ACC KERNELS LOOP";
2109 case ST_OACC_END_KERNELS_LOOP
:
2110 p
= "!$ACC END KERNELS LOOP";
2115 case ST_OACC_END_DATA
:
2116 p
= "!$ACC END DATA";
2118 case ST_OACC_HOST_DATA
:
2119 p
= "!$ACC HOST_DATA";
2121 case ST_OACC_END_HOST_DATA
:
2122 p
= "!$ACC END HOST_DATA";
2127 case ST_OACC_END_LOOP
:
2128 p
= "!$ACC END LOOP";
2130 case ST_OACC_DECLARE
:
2131 p
= "!$ACC DECLARE";
2133 case ST_OACC_UPDATE
:
2142 case ST_OACC_ENTER_DATA
:
2143 p
= "!$ACC ENTER DATA";
2145 case ST_OACC_EXIT_DATA
:
2146 p
= "!$ACC EXIT DATA";
2148 case ST_OACC_ROUTINE
:
2149 p
= "!$ACC ROUTINE";
2151 case ST_OACC_ATOMIC
:
2154 case ST_OACC_END_ATOMIC
:
2155 p
= "!$ACC END ATOMIC";
2160 case ST_OMP_BARRIER
:
2161 p
= "!$OMP BARRIER";
2166 case ST_OMP_CANCELLATION_POINT
:
2167 p
= "!$OMP CANCELLATION POINT";
2169 case ST_OMP_CRITICAL
:
2170 p
= "!$OMP CRITICAL";
2172 case ST_OMP_DECLARE_REDUCTION
:
2173 p
= "!$OMP DECLARE REDUCTION";
2175 case ST_OMP_DECLARE_SIMD
:
2176 p
= "!$OMP DECLARE SIMD";
2178 case ST_OMP_DECLARE_TARGET
:
2179 p
= "!$OMP DECLARE TARGET";
2181 case ST_OMP_DISTRIBUTE
:
2182 p
= "!$OMP DISTRIBUTE";
2184 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
2185 p
= "!$OMP DISTRIBUTE PARALLEL DO";
2187 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2188 p
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
2190 case ST_OMP_DISTRIBUTE_SIMD
:
2191 p
= "!$OMP DISTRIBUTE SIMD";
2196 case ST_OMP_DO_SIMD
:
2197 p
= "!$OMP DO SIMD";
2199 case ST_OMP_END_ATOMIC
:
2200 p
= "!$OMP END ATOMIC";
2202 case ST_OMP_END_CRITICAL
:
2203 p
= "!$OMP END CRITICAL";
2205 case ST_OMP_END_DISTRIBUTE
:
2206 p
= "!$OMP END DISTRIBUTE";
2208 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO
:
2209 p
= "!$OMP END DISTRIBUTE PARALLEL DO";
2211 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
:
2212 p
= "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
2214 case ST_OMP_END_DISTRIBUTE_SIMD
:
2215 p
= "!$OMP END DISTRIBUTE SIMD";
2220 case ST_OMP_END_DO_SIMD
:
2221 p
= "!$OMP END DO SIMD";
2223 case ST_OMP_END_SIMD
:
2224 p
= "!$OMP END SIMD";
2226 case ST_OMP_END_MASTER
:
2227 p
= "!$OMP END MASTER";
2229 case ST_OMP_END_ORDERED
:
2230 p
= "!$OMP END ORDERED";
2232 case ST_OMP_END_PARALLEL
:
2233 p
= "!$OMP END PARALLEL";
2235 case ST_OMP_END_PARALLEL_DO
:
2236 p
= "!$OMP END PARALLEL DO";
2238 case ST_OMP_END_PARALLEL_DO_SIMD
:
2239 p
= "!$OMP END PARALLEL DO SIMD";
2241 case ST_OMP_END_PARALLEL_SECTIONS
:
2242 p
= "!$OMP END PARALLEL SECTIONS";
2244 case ST_OMP_END_PARALLEL_WORKSHARE
:
2245 p
= "!$OMP END PARALLEL WORKSHARE";
2247 case ST_OMP_END_SECTIONS
:
2248 p
= "!$OMP END SECTIONS";
2250 case ST_OMP_END_SINGLE
:
2251 p
= "!$OMP END SINGLE";
2253 case ST_OMP_END_TASK
:
2254 p
= "!$OMP END TASK";
2256 case ST_OMP_END_TARGET
:
2257 p
= "!$OMP END TARGET";
2259 case ST_OMP_END_TARGET_DATA
:
2260 p
= "!$OMP END TARGET DATA";
2262 case ST_OMP_END_TARGET_PARALLEL
:
2263 p
= "!$OMP END TARGET PARALLEL";
2265 case ST_OMP_END_TARGET_PARALLEL_DO
:
2266 p
= "!$OMP END TARGET PARALLEL DO";
2268 case ST_OMP_END_TARGET_PARALLEL_DO_SIMD
:
2269 p
= "!$OMP END TARGET PARALLEL DO SIMD";
2271 case ST_OMP_END_TARGET_SIMD
:
2272 p
= "!$OMP END TARGET SIMD";
2274 case ST_OMP_END_TARGET_TEAMS
:
2275 p
= "!$OMP END TARGET TEAMS";
2277 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
:
2278 p
= "!$OMP END TARGET TEAMS DISTRIBUTE";
2280 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2281 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2283 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2284 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2286 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2287 p
= "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2289 case ST_OMP_END_TASKGROUP
:
2290 p
= "!$OMP END TASKGROUP";
2292 case ST_OMP_END_TASKLOOP
:
2293 p
= "!$OMP END TASKLOOP";
2295 case ST_OMP_END_TASKLOOP_SIMD
:
2296 p
= "!$OMP END TASKLOOP SIMD";
2298 case ST_OMP_END_TEAMS
:
2299 p
= "!$OMP END TEAMS";
2301 case ST_OMP_END_TEAMS_DISTRIBUTE
:
2302 p
= "!$OMP END TEAMS DISTRIBUTE";
2304 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2305 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2307 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2308 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2310 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
:
2311 p
= "!$OMP END TEAMS DISTRIBUTE SIMD";
2313 case ST_OMP_END_WORKSHARE
:
2314 p
= "!$OMP END WORKSHARE";
2322 case ST_OMP_ORDERED
:
2323 case ST_OMP_ORDERED_DEPEND
:
2324 p
= "!$OMP ORDERED";
2326 case ST_OMP_PARALLEL
:
2327 p
= "!$OMP PARALLEL";
2329 case ST_OMP_PARALLEL_DO
:
2330 p
= "!$OMP PARALLEL DO";
2332 case ST_OMP_PARALLEL_DO_SIMD
:
2333 p
= "!$OMP PARALLEL DO SIMD";
2335 case ST_OMP_PARALLEL_SECTIONS
:
2336 p
= "!$OMP PARALLEL SECTIONS";
2338 case ST_OMP_PARALLEL_WORKSHARE
:
2339 p
= "!$OMP PARALLEL WORKSHARE";
2341 case ST_OMP_SECTIONS
:
2342 p
= "!$OMP SECTIONS";
2344 case ST_OMP_SECTION
:
2345 p
= "!$OMP SECTION";
2356 case ST_OMP_TARGET_DATA
:
2357 p
= "!$OMP TARGET DATA";
2359 case ST_OMP_TARGET_ENTER_DATA
:
2360 p
= "!$OMP TARGET ENTER DATA";
2362 case ST_OMP_TARGET_EXIT_DATA
:
2363 p
= "!$OMP TARGET EXIT DATA";
2365 case ST_OMP_TARGET_PARALLEL
:
2366 p
= "!$OMP TARGET PARALLEL";
2368 case ST_OMP_TARGET_PARALLEL_DO
:
2369 p
= "!$OMP TARGET PARALLEL DO";
2371 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
2372 p
= "!$OMP TARGET PARALLEL DO SIMD";
2374 case ST_OMP_TARGET_SIMD
:
2375 p
= "!$OMP TARGET SIMD";
2377 case ST_OMP_TARGET_TEAMS
:
2378 p
= "!$OMP TARGET TEAMS";
2380 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
2381 p
= "!$OMP TARGET TEAMS DISTRIBUTE";
2383 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2384 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2386 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2387 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2389 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2390 p
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2392 case ST_OMP_TARGET_UPDATE
:
2393 p
= "!$OMP TARGET UPDATE";
2398 case ST_OMP_TASKGROUP
:
2399 p
= "!$OMP TASKGROUP";
2401 case ST_OMP_TASKLOOP
:
2402 p
= "!$OMP TASKLOOP";
2404 case ST_OMP_TASKLOOP_SIMD
:
2405 p
= "!$OMP TASKLOOP SIMD";
2407 case ST_OMP_TASKWAIT
:
2408 p
= "!$OMP TASKWAIT";
2410 case ST_OMP_TASKYIELD
:
2411 p
= "!$OMP TASKYIELD";
2416 case ST_OMP_TEAMS_DISTRIBUTE
:
2417 p
= "!$OMP TEAMS DISTRIBUTE";
2419 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2420 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2422 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2423 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2425 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
2426 p
= "!$OMP TEAMS DISTRIBUTE SIMD";
2428 case ST_OMP_THREADPRIVATE
:
2429 p
= "!$OMP THREADPRIVATE";
2431 case ST_OMP_WORKSHARE
:
2432 p
= "!$OMP WORKSHARE";
2435 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2442 /* Create a symbol for the main program and assign it to ns->proc_name. */
2445 main_program_symbol (gfc_namespace
*ns
, const char *name
)
2447 gfc_symbol
*main_program
;
2448 symbol_attribute attr
;
2450 gfc_get_symbol (name
, ns
, &main_program
);
2451 gfc_clear_attr (&attr
);
2452 attr
.flavor
= FL_PROGRAM
;
2453 attr
.proc
= PROC_UNKNOWN
;
2454 attr
.subroutine
= 1;
2455 attr
.access
= ACCESS_PUBLIC
;
2456 attr
.is_main_program
= 1;
2457 main_program
->attr
= attr
;
2458 main_program
->declared_at
= gfc_current_locus
;
2459 ns
->proc_name
= main_program
;
2460 gfc_commit_symbols ();
2464 /* Do whatever is necessary to accept the last statement. */
2467 accept_statement (gfc_statement st
)
2471 case ST_IMPLICIT_NONE
:
2479 gfc_current_ns
->proc_name
= gfc_new_block
;
2482 /* If the statement is the end of a block, lay down a special code
2483 that allows a branch to the end of the block from within the
2484 construct. IF and SELECT are treated differently from DO
2485 (where EXEC_NOP is added inside the loop) for two
2487 1. END DO has a meaning in the sense that after a GOTO to
2488 it, the loop counter must be increased.
2489 2. IF blocks and SELECT blocks can consist of multiple
2490 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
2491 Putting the label before the END IF would make the jump
2492 from, say, the ELSE IF block to the END IF illegal. */
2496 case ST_END_CRITICAL
:
2497 if (gfc_statement_label
!= NULL
)
2499 new_st
.op
= EXEC_END_NESTED_BLOCK
;
2504 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
2505 one parallel block. Thus, we add the special code to the nested block
2506 itself, instead of the parent one. */
2508 case ST_END_ASSOCIATE
:
2509 if (gfc_statement_label
!= NULL
)
2511 new_st
.op
= EXEC_END_BLOCK
;
2516 /* The end-of-program unit statements do not get the special
2517 marker and require a statement of some sort if they are a
2520 case ST_END_PROGRAM
:
2521 case ST_END_FUNCTION
:
2522 case ST_END_SUBROUTINE
:
2523 if (gfc_statement_label
!= NULL
)
2525 new_st
.op
= EXEC_RETURN
;
2530 new_st
.op
= EXEC_END_PROCEDURE
;
2546 gfc_commit_symbols ();
2547 gfc_warning_check ();
2548 gfc_clear_new_st ();
2552 /* Undo anything tentative that has been built for the current statement,
2553 except if a gfc_charlen structure has been added to current namespace's
2554 list of gfc_charlen structure. */
2557 reject_statement (void)
2559 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
2560 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
2562 gfc_reject_data (gfc_current_ns
);
2564 gfc_new_block
= NULL
;
2565 gfc_undo_symbols ();
2566 gfc_clear_warning ();
2567 undo_new_statement ();
2571 /* Generic complaint about an out of order statement. We also do
2572 whatever is necessary to clean up. */
2575 unexpected_statement (gfc_statement st
)
2577 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
2579 reject_statement ();
2583 /* Given the next statement seen by the matcher, make sure that it is
2584 in proper order with the last. This subroutine is initialized by
2585 calling it with an argument of ST_NONE. If there is a problem, we
2586 issue an error and return false. Otherwise we return true.
2588 Individual parsers need to verify that the statements seen are
2589 valid before calling here, i.e., ENTRY statements are not allowed in
2590 INTERFACE blocks. The following diagram is taken from the standard:
2592 +---------------------------------------+
2593 | program subroutine function module |
2594 +---------------------------------------+
2596 +---------------------------------------+
2598 +---------------------------------------+
2600 | +-----------+------------------+
2601 | | parameter | implicit |
2602 | +-----------+------------------+
2603 | format | | derived type |
2604 | entry | parameter | interface |
2605 | | data | specification |
2606 | | | statement func |
2607 | +-----------+------------------+
2608 | | data | executable |
2609 +--------+-----------+------------------+
2611 +---------------------------------------+
2612 | internal module/subprogram |
2613 +---------------------------------------+
2615 +---------------------------------------+
2624 ORDER_IMPLICIT_NONE
,
2632 enum state_order state
;
2633 gfc_statement last_statement
;
2639 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
2645 p
->state
= ORDER_START
;
2649 if (p
->state
> ORDER_USE
)
2651 p
->state
= ORDER_USE
;
2655 if (p
->state
> ORDER_IMPORT
)
2657 p
->state
= ORDER_IMPORT
;
2660 case ST_IMPLICIT_NONE
:
2661 if (p
->state
> ORDER_IMPLICIT
)
2664 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2665 statement disqualifies a USE but not an IMPLICIT NONE.
2666 Duplicate IMPLICIT NONEs are caught when the implicit types
2669 p
->state
= ORDER_IMPLICIT_NONE
;
2673 if (p
->state
> ORDER_IMPLICIT
)
2675 p
->state
= ORDER_IMPLICIT
;
2680 if (p
->state
< ORDER_IMPLICIT_NONE
)
2681 p
->state
= ORDER_IMPLICIT_NONE
;
2685 if (p
->state
>= ORDER_EXEC
)
2687 if (p
->state
< ORDER_IMPLICIT
)
2688 p
->state
= ORDER_IMPLICIT
;
2692 if (p
->state
< ORDER_SPEC
)
2693 p
->state
= ORDER_SPEC
;
2698 case ST_STRUCTURE_DECL
:
2699 case ST_DERIVED_DECL
:
2701 if (p
->state
>= ORDER_EXEC
)
2703 if (p
->state
< ORDER_SPEC
)
2704 p
->state
= ORDER_SPEC
;
2708 /* The OpenMP directives have to be somewhere in the specification
2709 part, but there are no further requirements on their ordering.
2710 Thus don't adjust p->state, just ignore them. */
2711 if (p
->state
>= ORDER_EXEC
)
2717 if (p
->state
< ORDER_EXEC
)
2718 p
->state
= ORDER_EXEC
;
2725 /* All is well, record the statement in case we need it next time. */
2726 p
->where
= gfc_current_locus
;
2727 p
->last_statement
= st
;
2732 gfc_error ("%s statement at %C cannot follow %s statement at %L",
2733 gfc_ascii_statement (st
),
2734 gfc_ascii_statement (p
->last_statement
), &p
->where
);
2740 /* Handle an unexpected end of file. This is a show-stopper... */
2742 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
2745 unexpected_eof (void)
2749 gfc_error ("Unexpected end of file in %qs", gfc_source_file
);
2751 /* Memory cleanup. Move to "second to last". */
2752 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
2755 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
2758 longjmp (eof_buf
, 1);
2760 /* Avoids build error on systems where longjmp is not declared noreturn. */
2765 /* Parse the CONTAINS section of a derived type definition. */
2767 gfc_access gfc_typebound_default_access
;
2770 parse_derived_contains (void)
2773 bool seen_private
= false;
2774 bool seen_comps
= false;
2775 bool error_flag
= false;
2778 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2779 gcc_assert (gfc_current_block ());
2781 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
2783 if (gfc_current_block ()->attr
.sequence
)
2784 gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
2785 " section at %C", gfc_current_block ()->name
);
2786 if (gfc_current_block ()->attr
.is_bind_c
)
2787 gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
2788 " section at %C", gfc_current_block ()->name
);
2790 accept_statement (ST_CONTAINS
);
2791 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
2793 gfc_typebound_default_access
= ACCESS_PUBLIC
;
2799 st
= next_statement ();
2807 gfc_error ("Components in TYPE at %C must precede CONTAINS");
2811 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
2814 accept_statement (ST_PROCEDURE
);
2819 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
2822 accept_statement (ST_GENERIC
);
2827 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
2831 accept_statement (ST_FINAL
);
2839 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
2840 "at %C with empty CONTAINS section")))
2843 /* ST_END_TYPE is accepted by parse_derived after return. */
2847 if (!gfc_find_state (COMP_MODULE
))
2849 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2856 gfc_error ("PRIVATE statement at %C must precede procedure"
2863 gfc_error ("Duplicate PRIVATE statement at %C");
2867 accept_statement (ST_PRIVATE
);
2868 gfc_typebound_default_access
= ACCESS_PRIVATE
;
2869 seen_private
= true;
2873 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2877 gfc_error ("Already inside a CONTAINS block at %C");
2881 unexpected_statement (st
);
2889 reject_statement ();
2893 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2899 /* Set attributes for the parent symbol based on the attributes of a component
2900 and raise errors if conflicting attributes are found for the component. */
2903 check_component (gfc_symbol
*sym
, gfc_component
*c
, gfc_component
**lockp
,
2904 gfc_component
**eventp
)
2906 bool coarray
, lock_type
, event_type
, allocatable
, pointer
;
2907 coarray
= lock_type
= event_type
= allocatable
= pointer
= false;
2908 gfc_component
*lock_comp
= NULL
, *event_comp
= NULL
;
2910 if (lockp
) lock_comp
= *lockp
;
2911 if (eventp
) event_comp
= *eventp
;
2913 /* Look for allocatable components. */
2914 if (c
->attr
.allocatable
2915 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2916 && CLASS_DATA (c
)->attr
.allocatable
)
2917 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
2918 && c
->ts
.u
.derived
->attr
.alloc_comp
))
2921 sym
->attr
.alloc_comp
= 1;
2924 /* Look for pointer components. */
2926 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2927 && CLASS_DATA (c
)->attr
.class_pointer
)
2928 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
2931 sym
->attr
.pointer_comp
= 1;
2934 /* Look for procedure pointer components. */
2935 if (c
->attr
.proc_pointer
2936 || (c
->ts
.type
== BT_DERIVED
2937 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
2938 sym
->attr
.proc_pointer_comp
= 1;
2940 /* Looking for coarray components. */
2941 if (c
->attr
.codimension
2942 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2943 && CLASS_DATA (c
)->attr
.codimension
))
2946 sym
->attr
.coarray_comp
= 1;
2949 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
2950 && !c
->attr
.pointer
)
2953 sym
->attr
.coarray_comp
= 1;
2956 /* Looking for lock_type components. */
2957 if ((c
->ts
.type
== BT_DERIVED
2958 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2959 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2960 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2961 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2962 == INTMOD_ISO_FORTRAN_ENV
2963 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2964 == ISOFORTRAN_LOCK_TYPE
)
2965 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
2966 && !allocatable
&& !pointer
))
2970 sym
->attr
.lock_comp
= 1;
2973 /* Looking for event_type components. */
2974 if ((c
->ts
.type
== BT_DERIVED
2975 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2976 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2977 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2978 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2979 == INTMOD_ISO_FORTRAN_ENV
2980 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2981 == ISOFORTRAN_EVENT_TYPE
)
2982 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.event_comp
2983 && !allocatable
&& !pointer
))
2987 sym
->attr
.event_comp
= 1;
2990 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2991 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2992 unless there are nondirect [allocatable or pointer] components
2993 involved (cf. 1.3.33.1 and 1.3.33.3). */
2995 if (pointer
&& !coarray
&& lock_type
)
2996 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2997 "codimension or be a subcomponent of a coarray, "
2998 "which is not possible as the component has the "
2999 "pointer attribute", c
->name
, &c
->loc
);
3000 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
3001 && c
->ts
.u
.derived
->attr
.lock_comp
)
3002 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3003 "of type LOCK_TYPE, which must have a codimension or be a "
3004 "subcomponent of a coarray", c
->name
, &c
->loc
);
3006 if (lock_type
&& allocatable
&& !coarray
)
3007 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
3008 "a codimension", c
->name
, &c
->loc
);
3009 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
3010 && c
->ts
.u
.derived
->attr
.lock_comp
)
3011 gfc_error ("Allocatable component %s at %L must have a codimension as "
3012 "it has a noncoarray subcomponent of type LOCK_TYPE",
3015 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
3016 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3017 "subcomponent of type LOCK_TYPE must have a codimension or "
3018 "be a subcomponent of a coarray. (Variables of type %s may "
3019 "not have a codimension as already a coarray "
3020 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
3022 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
3023 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3024 "subcomponent of type LOCK_TYPE must have a codimension or "
3025 "be a subcomponent of a coarray. (Variables of type %s may "
3026 "not have a codimension as %s at %L has a codimension or a "
3027 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
3028 sym
->name
, c
->name
, &c
->loc
);
3030 /* Similarly for EVENT TYPE. */
3032 if (pointer
&& !coarray
&& event_type
)
3033 gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
3034 "codimension or be a subcomponent of a coarray, "
3035 "which is not possible as the component has the "
3036 "pointer attribute", c
->name
, &c
->loc
);
3037 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
3038 && c
->ts
.u
.derived
->attr
.event_comp
)
3039 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3040 "of type EVENT_TYPE, which must have a codimension or be a "
3041 "subcomponent of a coarray", c
->name
, &c
->loc
);
3043 if (event_type
&& allocatable
&& !coarray
)
3044 gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
3045 "a codimension", c
->name
, &c
->loc
);
3046 else if (event_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
3047 && c
->ts
.u
.derived
->attr
.event_comp
)
3048 gfc_error ("Allocatable component %s at %L must have a codimension as "
3049 "it has a noncoarray subcomponent of type EVENT_TYPE",
3052 if (sym
->attr
.coarray_comp
&& !coarray
&& event_type
)
3053 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3054 "subcomponent of type EVENT_TYPE must have a codimension or "
3055 "be a subcomponent of a coarray. (Variables of type %s may "
3056 "not have a codimension as already a coarray "
3057 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
3059 if (sym
->attr
.event_comp
&& coarray
&& !event_type
)
3060 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3061 "subcomponent of type EVENT_TYPE must have a codimension or "
3062 "be a subcomponent of a coarray. (Variables of type %s may "
3063 "not have a codimension as %s at %L has a codimension or a "
3064 "coarray subcomponent)", event_comp
->name
, &event_comp
->loc
,
3065 sym
->name
, c
->name
, &c
->loc
);
3067 /* Look for private components. */
3068 if (sym
->component_access
== ACCESS_PRIVATE
3069 || c
->attr
.access
== ACCESS_PRIVATE
3070 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
3071 sym
->attr
.private_comp
= 1;
3073 if (lockp
) *lockp
= lock_comp
;
3074 if (eventp
) *eventp
= event_comp
;
3078 static void parse_struct_map (gfc_statement
);
3080 /* Parse a union component definition within a structure definition. */
3088 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3091 accept_statement(ST_UNION
);
3092 push_state (&s
, COMP_UNION
, gfc_new_block
);
3099 st
= next_statement ();
3100 /* Only MAP declarations valid within a union. */
3107 accept_statement (ST_MAP
);
3108 parse_struct_map (ST_MAP
);
3109 /* Add a component to the union for each map. */
3110 if (!gfc_add_component (un
, gfc_new_block
->name
, &c
))
3112 gfc_internal_error ("failed to create map component '%s'",
3113 gfc_new_block
->name
);
3114 reject_statement ();
3117 c
->ts
.type
= BT_DERIVED
;
3118 c
->ts
.u
.derived
= gfc_new_block
;
3119 /* Normally components get their initialization expressions when they
3120 are created in decl.c (build_struct) so we can look through the
3121 flat component list for initializers during resolution. Unions and
3122 maps create components along with their type definitions so we
3123 have to generate initializers here. */
3124 c
->initializer
= gfc_default_initializer (&c
->ts
);
3129 accept_statement (ST_END_UNION
);
3133 unexpected_statement (st
);
3138 for (c
= un
->components
; c
; c
= c
->next
)
3139 check_component (un
, c
, &lock_comp
, &event_comp
);
3141 /* Add the union as a component in its parent structure. */
3143 if (!gfc_add_component (gfc_current_block (), un
->name
, &c
))
3145 gfc_internal_error ("failed to create union component '%s'", un
->name
);
3146 reject_statement ();
3149 c
->ts
.type
= BT_UNION
;
3150 c
->ts
.u
.derived
= un
;
3151 c
->initializer
= gfc_default_initializer (&c
->ts
);
3153 un
->attr
.zero_comp
= un
->components
== NULL
;
3157 /* Parse a STRUCTURE or MAP. */
3160 parse_struct_map (gfc_statement block
)
3166 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3167 gfc_compile_state comp
;
3170 if (block
== ST_STRUCTURE_DECL
)
3172 comp
= COMP_STRUCTURE
;
3173 ends
= ST_END_STRUCTURE
;
3177 gcc_assert (block
== ST_MAP
);
3182 accept_statement(block
);
3183 push_state (&s
, comp
, gfc_new_block
);
3185 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3188 while (compiling_type
)
3190 st
= next_statement ();
3196 /* Nested structure declarations will be captured as ST_DATA_DECL. */
3197 case ST_STRUCTURE_DECL
:
3198 /* Let a more specific error make it to decode_statement(). */
3199 if (gfc_error_check () == 0)
3200 gfc_error ("Syntax error in nested structure declaration at %C");
3201 reject_statement ();
3202 /* Skip the rest of this statement. */
3203 gfc_error_recovery ();
3207 accept_statement (ST_UNION
);
3212 /* The data declaration was a nested/ad-hoc STRUCTURE field. */
3213 accept_statement (ST_DATA_DECL
);
3214 if (gfc_new_block
&& gfc_new_block
!= gfc_current_block ()
3215 && gfc_new_block
->attr
.flavor
== FL_STRUCT
)
3216 parse_struct_map (ST_STRUCTURE_DECL
);
3219 case ST_END_STRUCTURE
:
3223 accept_statement (st
);
3227 unexpected_statement (st
);
3231 unexpected_statement (st
);
3236 /* Validate each component. */
3237 sym
= gfc_current_block ();
3238 for (c
= sym
->components
; c
; c
= c
->next
)
3239 check_component (sym
, c
, &lock_comp
, &event_comp
);
3241 sym
->attr
.zero_comp
= (sym
->components
== NULL
);
3243 /* Allow parse_union to find this structure to add to its list of maps. */
3244 if (block
== ST_MAP
)
3245 gfc_new_block
= gfc_current_block ();
3251 /* Parse a derived type. */
3254 parse_derived (void)
3256 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
3260 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3262 accept_statement (ST_DERIVED_DECL
);
3263 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
3265 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3272 while (compiling_type
)
3274 st
= next_statement ();
3282 accept_statement (st
);
3287 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
3294 if (!seen_component
)
3295 gfc_notify_std (GFC_STD_F2003
, "Derived type "
3296 "definition at %C without components");
3298 accept_statement (ST_END_TYPE
);
3302 if (!gfc_find_state (COMP_MODULE
))
3304 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3311 gfc_error ("PRIVATE statement at %C must precede "
3312 "structure components");
3317 gfc_error ("Duplicate PRIVATE statement at %C");
3319 s
.sym
->component_access
= ACCESS_PRIVATE
;
3321 accept_statement (ST_PRIVATE
);
3328 gfc_error ("SEQUENCE statement at %C must precede "
3329 "structure components");
3333 if (gfc_current_block ()->attr
.sequence
)
3334 gfc_warning (0, "SEQUENCE attribute at %C already specified in "
3339 gfc_error ("Duplicate SEQUENCE statement at %C");
3343 gfc_add_sequence (&gfc_current_block ()->attr
,
3344 gfc_current_block ()->name
, NULL
);
3348 gfc_notify_std (GFC_STD_F2003
,
3349 "CONTAINS block in derived type"
3350 " definition at %C");
3352 accept_statement (ST_CONTAINS
);
3353 parse_derived_contains ();
3357 unexpected_statement (st
);
3362 /* need to verify that all fields of the derived type are
3363 * interoperable with C if the type is declared to be bind(c)
3365 sym
= gfc_current_block ();
3366 for (c
= sym
->components
; c
; c
= c
->next
)
3367 check_component (sym
, c
, &lock_comp
, &event_comp
);
3369 if (!seen_component
)
3370 sym
->attr
.zero_comp
= 1;
3376 /* Parse an ENUM. */
3384 int seen_enumerator
= 0;
3386 push_state (&s
, COMP_ENUM
, gfc_new_block
);
3390 while (compiling_enum
)
3392 st
= next_statement ();
3400 seen_enumerator
= 1;
3401 accept_statement (st
);
3406 if (!seen_enumerator
)
3407 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
3408 accept_statement (st
);
3412 gfc_free_enum_history ();
3413 unexpected_statement (st
);
3421 /* Parse an interface. We must be able to deal with the possibility
3422 of recursive interfaces. The parse_spec() subroutine is mutually
3423 recursive with parse_interface(). */
3425 static gfc_statement
parse_spec (gfc_statement
);
3428 parse_interface (void)
3430 gfc_compile_state new_state
= COMP_NONE
, current_state
;
3431 gfc_symbol
*prog_unit
, *sym
;
3432 gfc_interface_info save
;
3433 gfc_state_data s1
, s2
;
3436 accept_statement (ST_INTERFACE
);
3438 current_interface
.ns
= gfc_current_ns
;
3439 save
= current_interface
;
3441 sym
= (current_interface
.type
== INTERFACE_GENERIC
3442 || current_interface
.type
== INTERFACE_USER_OP
)
3443 ? gfc_new_block
: NULL
;
3445 push_state (&s1
, COMP_INTERFACE
, sym
);
3446 current_state
= COMP_NONE
;
3449 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
3451 st
= next_statement ();
3459 if (st
== ST_SUBROUTINE
)
3460 new_state
= COMP_SUBROUTINE
;
3461 else if (st
== ST_FUNCTION
)
3462 new_state
= COMP_FUNCTION
;
3463 if (gfc_new_block
->attr
.pointer
)
3465 gfc_new_block
->attr
.pointer
= 0;
3466 gfc_new_block
->attr
.proc_pointer
= 1;
3468 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
3469 gfc_new_block
->formal
, NULL
))
3471 reject_statement ();
3472 gfc_free_namespace (gfc_current_ns
);
3475 /* F2008 C1210 forbids the IMPORT statement in module procedure
3476 interface bodies and the flag is set to import symbols. */
3477 if (gfc_new_block
->attr
.module_procedure
)
3478 gfc_current_ns
->has_import_set
= 1;
3482 case ST_MODULE_PROC
: /* The module procedure matcher makes
3483 sure the context is correct. */
3484 accept_statement (st
);
3485 gfc_free_namespace (gfc_current_ns
);
3488 case ST_END_INTERFACE
:
3489 gfc_free_namespace (gfc_current_ns
);
3490 gfc_current_ns
= current_interface
.ns
;
3494 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
3495 gfc_ascii_statement (st
));
3496 reject_statement ();
3497 gfc_free_namespace (gfc_current_ns
);
3502 /* Make sure that the generic name has the right attribute. */
3503 if (current_interface
.type
== INTERFACE_GENERIC
3504 && current_state
== COMP_NONE
)
3506 if (new_state
== COMP_FUNCTION
&& sym
)
3507 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
3508 else if (new_state
== COMP_SUBROUTINE
&& sym
)
3509 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
3511 current_state
= new_state
;
3514 if (current_interface
.type
== INTERFACE_ABSTRACT
)
3516 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
3517 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
3518 gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
3519 "cannot be the same as an intrinsic type",
3520 gfc_new_block
->name
);
3523 push_state (&s2
, new_state
, gfc_new_block
);
3524 accept_statement (st
);
3525 prog_unit
= gfc_new_block
;
3526 prog_unit
->formal_ns
= gfc_current_ns
;
3527 if (prog_unit
== prog_unit
->formal_ns
->proc_name
3528 && prog_unit
->ns
!= prog_unit
->formal_ns
)
3532 /* Read data declaration statements. */
3533 st
= parse_spec (ST_NONE
);
3534 in_specification_block
= true;
3536 /* Since the interface block does not permit an IMPLICIT statement,
3537 the default type for the function or the result must be taken
3538 from the formal namespace. */
3539 if (new_state
== COMP_FUNCTION
)
3541 if (prog_unit
->result
== prog_unit
3542 && prog_unit
->ts
.type
== BT_UNKNOWN
)
3543 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
3544 else if (prog_unit
->result
!= prog_unit
3545 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
3546 gfc_set_default_type (prog_unit
->result
, 1,
3547 prog_unit
->formal_ns
);
3550 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
3552 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
3553 gfc_ascii_statement (st
));
3554 reject_statement ();
3558 /* Add EXTERNAL attribute to function or subroutine. */
3559 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
3560 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
3562 current_interface
= save
;
3563 gfc_add_interface (prog_unit
);
3566 if (current_interface
.ns
3567 && current_interface
.ns
->proc_name
3568 && strcmp (current_interface
.ns
->proc_name
->name
,
3569 prog_unit
->name
) == 0)
3570 gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
3571 "enclosing procedure", prog_unit
->name
,
3572 ¤t_interface
.ns
->proc_name
->declared_at
);
3581 /* Associate function characteristics by going back to the function
3582 declaration and rematching the prefix. */
3585 match_deferred_characteristics (gfc_typespec
* ts
)
3588 match m
= MATCH_ERROR
;
3589 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3591 loc
= gfc_current_locus
;
3593 gfc_current_locus
= gfc_current_block ()->declared_at
;
3596 gfc_buffer_error (true);
3597 m
= gfc_match_prefix (ts
);
3598 gfc_buffer_error (false);
3600 if (ts
->type
== BT_DERIVED
)
3608 /* Only permit one go at the characteristic association. */
3612 /* Set the function locus correctly. If we have not found the
3613 function name, there is an error. */
3615 && gfc_match ("function% %n", name
) == MATCH_YES
3616 && strcmp (name
, gfc_current_block ()->name
) == 0)
3618 gfc_current_block ()->declared_at
= gfc_current_locus
;
3619 gfc_commit_symbols ();
3624 gfc_undo_symbols ();
3627 gfc_current_locus
=loc
;
3632 /* Check specification-expressions in the function result of the currently
3633 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
3634 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
3635 scope are not yet parsed so this has to be delayed up to parse_spec. */
3638 check_function_result_typed (void)
3642 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
3644 if (!gfc_current_ns
->proc_name
->result
) return;
3646 ts
= gfc_current_ns
->proc_name
->result
->ts
;
3648 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
3649 /* TODO: Extend when KIND type parameters are implemented. */
3650 if (ts
.type
== BT_CHARACTER
&& ts
.u
.cl
&& ts
.u
.cl
->length
)
3651 gfc_expr_check_typed (ts
.u
.cl
->length
, gfc_current_ns
, true);
3655 /* Parse a set of specification statements. Returns the statement
3656 that doesn't fit. */
3658 static gfc_statement
3659 parse_spec (gfc_statement st
)
3662 bool function_result_typed
= false;
3663 bool bad_characteristic
= false;
3666 in_specification_block
= true;
3668 verify_st_order (&ss
, ST_NONE
, false);
3670 st
= next_statement ();
3672 /* If we are not inside a function or don't have a result specified so far,
3673 do nothing special about it. */
3674 if (gfc_current_state () != COMP_FUNCTION
)
3675 function_result_typed
= true;
3678 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
3681 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
3682 function_result_typed
= true;
3687 /* If we're inside a BLOCK construct, some statements are disallowed.
3688 Check this here. Attribute declaration statements like INTENT, OPTIONAL
3689 or VALUE are also disallowed, but they don't have a particular ST_*
3690 key so we have to check for them individually in their matcher routine. */
3691 if (gfc_current_state () == COMP_BLOCK
)
3695 case ST_IMPLICIT_NONE
:
3698 case ST_EQUIVALENCE
:
3699 case ST_STATEMENT_FUNCTION
:
3700 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
3701 gfc_ascii_statement (st
));
3702 reject_statement ();
3708 else if (gfc_current_state () == COMP_BLOCK_DATA
)
3709 /* Fortran 2008, C1116. */
3716 case ST_DERIVED_DECL
:
3717 case ST_END_BLOCK_DATA
:
3718 case ST_EQUIVALENCE
:
3720 case ST_IMPLICIT_NONE
:
3721 case ST_OMP_THREADPRIVATE
:
3723 case ST_STRUCTURE_DECL
:
3732 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
3733 gfc_ascii_statement (st
));
3734 reject_statement ();
3738 /* If we find a statement that can not be followed by an IMPLICIT statement
3739 (and thus we can expect to see none any further), type the function result
3740 if it has not yet been typed. Be careful not to give the END statement
3741 to verify_st_order! */
3742 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
3744 bool verify_now
= false;
3746 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
3751 verify_st_order (&dummyss
, ST_NONE
, false);
3752 verify_st_order (&dummyss
, st
, false);
3754 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
3760 check_function_result_typed ();
3761 function_result_typed
= true;
3770 case ST_IMPLICIT_NONE
:
3772 if (!function_result_typed
)
3774 check_function_result_typed ();
3775 function_result_typed
= true;
3781 case ST_DATA
: /* Not allowed in interfaces */
3782 if (gfc_current_state () == COMP_INTERFACE
)
3792 case ST_STRUCTURE_DECL
:
3793 case ST_DERIVED_DECL
:
3797 if (!verify_st_order (&ss
, st
, false))
3799 reject_statement ();
3800 st
= next_statement ();
3810 case ST_STRUCTURE_DECL
:
3811 parse_struct_map (ST_STRUCTURE_DECL
);
3814 case ST_DERIVED_DECL
:
3820 if (gfc_current_state () != COMP_MODULE
)
3822 gfc_error ("%s statement must appear in a MODULE",
3823 gfc_ascii_statement (st
));
3824 reject_statement ();
3828 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
3830 gfc_error ("%s statement at %C follows another accessibility "
3831 "specification", gfc_ascii_statement (st
));
3832 reject_statement ();
3836 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
3837 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3841 case ST_STATEMENT_FUNCTION
:
3842 if (gfc_current_state () == COMP_MODULE
3843 || gfc_current_state () == COMP_SUBMODULE
)
3845 unexpected_statement (st
);
3853 accept_statement (st
);
3854 st
= next_statement ();
3858 accept_statement (st
);
3860 st
= next_statement ();
3863 case ST_GET_FCN_CHARACTERISTICS
:
3864 /* This statement triggers the association of a function's result
3866 ts
= &gfc_current_block ()->result
->ts
;
3867 if (match_deferred_characteristics (ts
) != MATCH_YES
)
3868 bad_characteristic
= true;
3870 st
= next_statement ();
3877 /* If match_deferred_characteristics failed, then there is an error. */
3878 if (bad_characteristic
)
3880 ts
= &gfc_current_block ()->result
->ts
;
3881 if (ts
->type
!= BT_DERIVED
)
3882 gfc_error ("Bad kind expression for function %qs at %L",
3883 gfc_current_block ()->name
,
3884 &gfc_current_block ()->declared_at
);
3886 gfc_error ("The type for function %qs at %L is not accessible",
3887 gfc_current_block ()->name
,
3888 &gfc_current_block ()->declared_at
);
3890 gfc_current_block ()->ts
.kind
= 0;
3891 /* Keep the derived type; if it's bad, it will be discovered later. */
3892 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
3893 ts
->type
= BT_UNKNOWN
;
3896 in_specification_block
= false;
3902 /* Parse a WHERE block, (not a simple WHERE statement). */
3905 parse_where_block (void)
3907 int seen_empty_else
;
3912 accept_statement (ST_WHERE_BLOCK
);
3913 top
= gfc_state_stack
->tail
;
3915 push_state (&s
, COMP_WHERE
, gfc_new_block
);
3917 d
= add_statement ();
3918 d
->expr1
= top
->expr1
;
3924 seen_empty_else
= 0;
3928 st
= next_statement ();
3934 case ST_WHERE_BLOCK
:
3935 parse_where_block ();
3940 accept_statement (st
);
3944 if (seen_empty_else
)
3946 gfc_error ("ELSEWHERE statement at %C follows previous "
3947 "unmasked ELSEWHERE");
3948 reject_statement ();
3952 if (new_st
.expr1
== NULL
)
3953 seen_empty_else
= 1;
3955 d
= new_level (gfc_state_stack
->head
);
3957 d
->expr1
= new_st
.expr1
;
3959 accept_statement (st
);
3964 accept_statement (st
);
3968 gfc_error ("Unexpected %s statement in WHERE block at %C",
3969 gfc_ascii_statement (st
));
3970 reject_statement ();
3974 while (st
!= ST_END_WHERE
);
3980 /* Parse a FORALL block (not a simple FORALL statement). */
3983 parse_forall_block (void)
3989 accept_statement (ST_FORALL_BLOCK
);
3990 top
= gfc_state_stack
->tail
;
3992 push_state (&s
, COMP_FORALL
, gfc_new_block
);
3994 d
= add_statement ();
3995 d
->op
= EXEC_FORALL
;
4000 st
= next_statement ();
4005 case ST_POINTER_ASSIGNMENT
:
4008 accept_statement (st
);
4011 case ST_WHERE_BLOCK
:
4012 parse_where_block ();
4015 case ST_FORALL_BLOCK
:
4016 parse_forall_block ();
4020 accept_statement (st
);
4027 gfc_error ("Unexpected %s statement in FORALL block at %C",
4028 gfc_ascii_statement (st
));
4030 reject_statement ();
4034 while (st
!= ST_END_FORALL
);
4040 static gfc_statement
parse_executable (gfc_statement
);
4042 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
4045 parse_if_block (void)
4054 accept_statement (ST_IF_BLOCK
);
4056 top
= gfc_state_stack
->tail
;
4057 push_state (&s
, COMP_IF
, gfc_new_block
);
4059 new_st
.op
= EXEC_IF
;
4060 d
= add_statement ();
4062 d
->expr1
= top
->expr1
;
4068 st
= parse_executable (ST_NONE
);
4078 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
4079 "statement at %L", &else_locus
);
4081 reject_statement ();
4085 d
= new_level (gfc_state_stack
->head
);
4087 d
->expr1
= new_st
.expr1
;
4089 accept_statement (st
);
4096 gfc_error ("Duplicate ELSE statements at %L and %C",
4098 reject_statement ();
4103 else_locus
= gfc_current_locus
;
4105 d
= new_level (gfc_state_stack
->head
);
4108 accept_statement (st
);
4116 unexpected_statement (st
);
4120 while (st
!= ST_ENDIF
);
4123 accept_statement (st
);
4127 /* Parse a SELECT block. */
4130 parse_select_block (void)
4136 accept_statement (ST_SELECT_CASE
);
4138 cp
= gfc_state_stack
->tail
;
4139 push_state (&s
, COMP_SELECT
, gfc_new_block
);
4141 /* Make sure that the next statement is a CASE or END SELECT. */
4144 st
= next_statement ();
4147 if (st
== ST_END_SELECT
)
4149 /* Empty SELECT CASE is OK. */
4150 accept_statement (st
);
4157 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
4160 reject_statement ();
4163 /* At this point, we're got a nonempty select block. */
4164 cp
= new_level (cp
);
4167 accept_statement (st
);
4171 st
= parse_executable (ST_NONE
);
4178 cp
= new_level (gfc_state_stack
->head
);
4180 gfc_clear_new_st ();
4182 accept_statement (st
);
4188 /* Can't have an executable statement because of
4189 parse_executable(). */
4191 unexpected_statement (st
);
4195 while (st
!= ST_END_SELECT
);
4198 accept_statement (st
);
4202 /* Pop the current selector from the SELECT TYPE stack. */
4205 select_type_pop (void)
4207 gfc_select_type_stack
*old
= select_type_stack
;
4208 select_type_stack
= old
->prev
;
4213 /* Parse a SELECT TYPE construct (F03:R821). */
4216 parse_select_type_block (void)
4222 gfc_current_ns
= new_st
.ext
.block
.ns
;
4223 accept_statement (ST_SELECT_TYPE
);
4225 cp
= gfc_state_stack
->tail
;
4226 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
4228 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
4232 st
= next_statement ();
4235 if (st
== ST_END_SELECT
)
4236 /* Empty SELECT CASE is OK. */
4238 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
4241 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
4242 "following SELECT TYPE at %C");
4244 reject_statement ();
4247 /* At this point, we're got a nonempty select block. */
4248 cp
= new_level (cp
);
4251 accept_statement (st
);
4255 st
= parse_executable (ST_NONE
);
4263 cp
= new_level (gfc_state_stack
->head
);
4265 gfc_clear_new_st ();
4267 accept_statement (st
);
4273 /* Can't have an executable statement because of
4274 parse_executable(). */
4276 unexpected_statement (st
);
4280 while (st
!= ST_END_SELECT
);
4284 accept_statement (st
);
4285 gfc_current_ns
= gfc_current_ns
->parent
;
4290 /* Given a symbol, make sure it is not an iteration variable for a DO
4291 statement. This subroutine is called when the symbol is seen in a
4292 context that causes it to become redefined. If the symbol is an
4293 iterator, we generate an error message and return nonzero. */
4296 gfc_check_do_variable (gfc_symtree
*st
)
4300 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
4301 if (s
->do_variable
== st
)
4303 gfc_error_now ("Variable %qs at %C cannot be redefined inside "
4304 "loop beginning at %L", st
->name
, &s
->head
->loc
);
4312 /* Checks to see if the current statement label closes an enddo.
4313 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
4314 an error) if it incorrectly closes an ENDDO. */
4317 check_do_closure (void)
4321 if (gfc_statement_label
== NULL
)
4324 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
4325 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4329 return 0; /* No loops to close */
4331 if (p
->ext
.end_do_label
== gfc_statement_label
)
4333 if (p
== gfc_state_stack
)
4336 gfc_error ("End of nonblock DO statement at %C is within another block");
4340 /* At this point, the label doesn't terminate the innermost loop.
4341 Make sure it doesn't terminate another one. */
4342 for (; p
; p
= p
->previous
)
4343 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4344 && p
->ext
.end_do_label
== gfc_statement_label
)
4346 gfc_error ("End of nonblock DO statement at %C is interwoven "
4347 "with another DO loop");
4355 /* Parse a series of contained program units. */
4357 static void parse_progunit (gfc_statement
);
4360 /* Parse a CRITICAL block. */
4363 parse_critical_block (void)
4366 gfc_state_data s
, *sd
;
4369 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4370 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
4371 gfc_error_now (is_oacc (sd
)
4372 ? G_("CRITICAL block inside of OpenACC region at %C")
4373 : G_("CRITICAL block inside of OpenMP region at %C"));
4375 s
.ext
.end_do_label
= new_st
.label1
;
4377 accept_statement (ST_CRITICAL
);
4378 top
= gfc_state_stack
->tail
;
4380 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
4382 d
= add_statement ();
4383 d
->op
= EXEC_CRITICAL
;
4388 st
= parse_executable (ST_NONE
);
4396 case ST_END_CRITICAL
:
4397 if (s
.ext
.end_do_label
!= NULL
4398 && s
.ext
.end_do_label
!= gfc_statement_label
)
4399 gfc_error_now ("Statement label in END CRITICAL at %C does not "
4400 "match CRITICAL label");
4402 if (gfc_statement_label
!= NULL
)
4404 new_st
.op
= EXEC_NOP
;
4410 unexpected_statement (st
);
4414 while (st
!= ST_END_CRITICAL
);
4417 accept_statement (st
);
4421 /* Set up the local namespace for a BLOCK construct. */
4424 gfc_build_block_ns (gfc_namespace
*parent_ns
)
4426 gfc_namespace
* my_ns
;
4427 static int numblock
= 1;
4429 my_ns
= gfc_get_namespace (parent_ns
, 1);
4430 my_ns
->construct_entities
= 1;
4432 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
4433 code generation (so it must not be NULL).
4434 We set its recursive argument if our container procedure is recursive, so
4435 that local variables are accordingly placed on the stack when it
4436 will be necessary. */
4438 my_ns
->proc_name
= gfc_new_block
;
4442 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
4444 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
4445 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
4446 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
4447 my_ns
->proc_name
->name
, NULL
);
4449 gfc_commit_symbol (my_ns
->proc_name
);
4452 if (parent_ns
->proc_name
)
4453 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
4459 /* Parse a BLOCK construct. */
4462 parse_block_construct (void)
4464 gfc_namespace
* my_ns
;
4465 gfc_namespace
* my_parent
;
4468 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
4470 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4472 new_st
.op
= EXEC_BLOCK
;
4473 new_st
.ext
.block
.ns
= my_ns
;
4474 new_st
.ext
.block
.assoc
= NULL
;
4475 accept_statement (ST_BLOCK
);
4477 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
4478 gfc_current_ns
= my_ns
;
4479 my_parent
= my_ns
->parent
;
4481 parse_progunit (ST_NONE
);
4483 /* Don't depend on the value of gfc_current_ns; it might have been
4484 reset if the block had errors and was cleaned up. */
4485 gfc_current_ns
= my_parent
;
4491 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
4492 behind the scenes with compiler-generated variables. */
4495 parse_associate (void)
4497 gfc_namespace
* my_ns
;
4500 gfc_association_list
* a
;
4502 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
4504 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4506 new_st
.op
= EXEC_BLOCK
;
4507 new_st
.ext
.block
.ns
= my_ns
;
4508 gcc_assert (new_st
.ext
.block
.assoc
);
4510 /* Add all associate-names as BLOCK variables. Creating them is enough
4511 for now, they'll get their values during trans-* phase. */
4512 gfc_current_ns
= my_ns
;
4513 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
4517 gfc_array_ref
*array_ref
;
4519 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
4523 sym
->attr
.flavor
= FL_VARIABLE
;
4525 sym
->declared_at
= a
->where
;
4526 gfc_set_sym_referenced (sym
);
4528 /* Initialize the typespec. It is not available in all cases,
4529 however, as it may only be set on the target during resolution.
4530 Still, sometimes it helps to have it right now -- especially
4531 for parsing component references on the associate-name
4532 in case of association to a derived-type. */
4533 sym
->ts
= a
->target
->ts
;
4535 /* Check if the target expression is array valued. This can not always
4536 be done by looking at target.rank, because that might not have been
4537 set yet. Therefore traverse the chain of refs, looking for the last
4538 array ref and evaluate that. */
4540 for (ref
= a
->target
->ref
; ref
; ref
= ref
->next
)
4541 if (ref
->type
== REF_ARRAY
)
4542 array_ref
= &ref
->u
.ar
;
4543 if (array_ref
|| a
->target
->rank
)
4550 /* Count the dimension, that have a non-scalar extend. */
4551 for (dim
= 0; dim
< array_ref
->dimen
; ++dim
)
4552 if (array_ref
->dimen_type
[dim
] != DIMEN_ELEMENT
4553 && !(array_ref
->dimen_type
[dim
] == DIMEN_UNKNOWN
4554 && array_ref
->end
[dim
] == NULL
4555 && array_ref
->start
[dim
] != NULL
))
4559 rank
= a
->target
->rank
;
4560 /* When the rank is greater than zero then sym will be an array. */
4561 if (sym
->ts
.type
== BT_CLASS
)
4563 if ((!CLASS_DATA (sym
)->as
&& rank
!= 0)
4564 || (CLASS_DATA (sym
)->as
4565 && CLASS_DATA (sym
)->as
->rank
!= rank
))
4567 /* Don't just (re-)set the attr and as in the sym.ts,
4568 because this modifies the target's attr and as. Copy the
4569 data and do a build_class_symbol. */
4570 symbol_attribute attr
= CLASS_DATA (a
->target
)->attr
;
4571 int corank
= gfc_get_corank (a
->target
);
4576 as
= gfc_get_array_spec ();
4577 as
->type
= AS_DEFERRED
;
4579 as
->corank
= corank
;
4580 attr
.dimension
= rank
? 1 : 0;
4581 attr
.codimension
= corank
? 1 : 0;
4586 attr
.dimension
= attr
.codimension
= 0;
4589 type
= CLASS_DATA (sym
)->ts
;
4590 if (!gfc_build_class_symbol (&type
,
4594 sym
->ts
.type
= BT_CLASS
;
4595 sym
->attr
.class_ok
= 1;
4598 sym
->attr
.class_ok
= 1;
4600 else if ((!sym
->as
&& rank
!= 0)
4601 || (sym
->as
&& sym
->as
->rank
!= rank
))
4603 as
= gfc_get_array_spec ();
4604 as
->type
= AS_DEFERRED
;
4606 as
->corank
= gfc_get_corank (a
->target
);
4608 sym
->attr
.dimension
= 1;
4610 sym
->attr
.codimension
= 1;
4615 accept_statement (ST_ASSOCIATE
);
4616 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
4619 st
= parse_executable (ST_NONE
);
4626 accept_statement (st
);
4627 my_ns
->code
= gfc_state_stack
->head
;
4631 unexpected_statement (st
);
4635 gfc_current_ns
= gfc_current_ns
->parent
;
4640 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
4641 handled inside of parse_executable(), because they aren't really
4645 parse_do_block (void)
4654 s
.ext
.end_do_label
= new_st
.label1
;
4656 if (new_st
.ext
.iterator
!= NULL
)
4658 stree
= new_st
.ext
.iterator
->var
->symtree
;
4659 if (directive_unroll
!= -1)
4661 new_st
.ext
.iterator
->unroll
= directive_unroll
;
4662 directive_unroll
= -1;
4668 accept_statement (ST_DO
);
4670 top
= gfc_state_stack
->tail
;
4671 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
4674 s
.do_variable
= stree
;
4676 top
->block
= new_level (top
);
4677 top
->block
->op
= EXEC_DO
;
4680 st
= parse_executable (ST_NONE
);
4688 if (s
.ext
.end_do_label
!= NULL
4689 && s
.ext
.end_do_label
!= gfc_statement_label
)
4690 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
4693 if (gfc_statement_label
!= NULL
)
4695 new_st
.op
= EXEC_NOP
;
4700 case ST_IMPLIED_ENDDO
:
4701 /* If the do-stmt of this DO construct has a do-construct-name,
4702 the corresponding end-do must be an end-do-stmt (with a matching
4703 name, but in that case we must have seen ST_ENDDO first).
4704 We only complain about this in pedantic mode. */
4705 if (gfc_current_block () != NULL
)
4706 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
4707 &gfc_current_block()->declared_at
);
4712 unexpected_statement (st
);
4717 accept_statement (st
);
4721 /* Parse the statements of OpenMP do/parallel do. */
4723 static gfc_statement
4724 parse_omp_do (gfc_statement omp_st
)
4730 accept_statement (omp_st
);
4732 cp
= gfc_state_stack
->tail
;
4733 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4734 np
= new_level (cp
);
4740 st
= next_statement ();
4743 else if (st
== ST_DO
)
4746 unexpected_statement (st
);
4750 if (gfc_statement_label
!= NULL
4751 && gfc_state_stack
->previous
!= NULL
4752 && gfc_state_stack
->previous
->state
== COMP_DO
4753 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4761 there should be no !$OMP END DO. */
4763 return ST_IMPLIED_ENDDO
;
4766 check_do_closure ();
4769 st
= next_statement ();
4770 gfc_statement omp_end_st
= ST_OMP_END_DO
;
4773 case ST_OMP_DISTRIBUTE
: omp_end_st
= ST_OMP_END_DISTRIBUTE
; break;
4774 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4775 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4777 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4778 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4780 case ST_OMP_DISTRIBUTE_SIMD
:
4781 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4783 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
4784 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
4785 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
4786 case ST_OMP_PARALLEL_DO_SIMD
:
4787 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
4789 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
4790 case ST_OMP_TARGET_PARALLEL_DO
:
4791 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO
;
4793 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
4794 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO_SIMD
;
4796 case ST_OMP_TARGET_SIMD
: omp_end_st
= ST_OMP_END_TARGET_SIMD
; break;
4797 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4798 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4800 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4801 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4803 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4804 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4806 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4807 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4809 case ST_OMP_TASKLOOP
: omp_end_st
= ST_OMP_END_TASKLOOP
; break;
4810 case ST_OMP_TASKLOOP_SIMD
: omp_end_st
= ST_OMP_END_TASKLOOP_SIMD
; break;
4811 case ST_OMP_TEAMS_DISTRIBUTE
:
4812 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4814 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4815 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4817 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4818 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4820 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4821 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4823 default: gcc_unreachable ();
4825 if (st
== omp_end_st
)
4827 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
4828 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4830 gcc_assert (new_st
.op
== EXEC_NOP
);
4831 gfc_clear_new_st ();
4832 gfc_commit_symbols ();
4833 gfc_warning_check ();
4834 st
= next_statement ();
4840 /* Parse the statements of OpenMP atomic directive. */
4842 static gfc_statement
4843 parse_omp_oacc_atomic (bool omp_p
)
4845 gfc_statement st
, st_atomic
, st_end_atomic
;
4852 st_atomic
= ST_OMP_ATOMIC
;
4853 st_end_atomic
= ST_OMP_END_ATOMIC
;
4857 st_atomic
= ST_OACC_ATOMIC
;
4858 st_end_atomic
= ST_OACC_END_ATOMIC
;
4860 accept_statement (st_atomic
);
4862 cp
= gfc_state_stack
->tail
;
4863 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4864 np
= new_level (cp
);
4867 np
->ext
.omp_atomic
= cp
->ext
.omp_atomic
;
4868 count
= 1 + ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4869 == GFC_OMP_ATOMIC_CAPTURE
);
4873 st
= next_statement ();
4876 else if (st
== ST_ASSIGNMENT
)
4878 accept_statement (st
);
4882 unexpected_statement (st
);
4887 st
= next_statement ();
4888 if (st
== st_end_atomic
)
4890 gfc_clear_new_st ();
4891 gfc_commit_symbols ();
4892 gfc_warning_check ();
4893 st
= next_statement ();
4895 else if ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4896 == GFC_OMP_ATOMIC_CAPTURE
)
4897 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
4902 /* Parse the statements of an OpenACC structured block. */
4905 parse_oacc_structured_block (gfc_statement acc_st
)
4907 gfc_statement st
, acc_end_st
;
4909 gfc_state_data s
, *sd
;
4911 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4912 if (sd
->state
== COMP_CRITICAL
)
4913 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4915 accept_statement (acc_st
);
4917 cp
= gfc_state_stack
->tail
;
4918 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4919 np
= new_level (cp
);
4924 case ST_OACC_PARALLEL
:
4925 acc_end_st
= ST_OACC_END_PARALLEL
;
4927 case ST_OACC_KERNELS
:
4928 acc_end_st
= ST_OACC_END_KERNELS
;
4931 acc_end_st
= ST_OACC_END_DATA
;
4933 case ST_OACC_HOST_DATA
:
4934 acc_end_st
= ST_OACC_END_HOST_DATA
;
4942 st
= parse_executable (ST_NONE
);
4945 else if (st
!= acc_end_st
)
4947 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
4948 reject_statement ();
4951 while (st
!= acc_end_st
);
4953 gcc_assert (new_st
.op
== EXEC_NOP
);
4955 gfc_clear_new_st ();
4956 gfc_commit_symbols ();
4957 gfc_warning_check ();
4961 /* Parse the statements of OpenACC loop/parallel loop/kernels loop. */
4963 static gfc_statement
4964 parse_oacc_loop (gfc_statement acc_st
)
4968 gfc_state_data s
, *sd
;
4970 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4971 if (sd
->state
== COMP_CRITICAL
)
4972 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4974 accept_statement (acc_st
);
4976 cp
= gfc_state_stack
->tail
;
4977 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4978 np
= new_level (cp
);
4984 st
= next_statement ();
4987 else if (st
== ST_DO
)
4991 gfc_error ("Expected DO loop at %C");
4992 reject_statement ();
4997 if (gfc_statement_label
!= NULL
4998 && gfc_state_stack
->previous
!= NULL
4999 && gfc_state_stack
->previous
->state
== COMP_DO
5000 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
5003 return ST_IMPLIED_ENDDO
;
5006 check_do_closure ();
5009 st
= next_statement ();
5010 if (st
== ST_OACC_END_LOOP
)
5011 gfc_warning (0, "Redundant !$ACC END LOOP at %C");
5012 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
5013 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
5014 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
5016 gcc_assert (new_st
.op
== EXEC_NOP
);
5017 gfc_clear_new_st ();
5018 gfc_commit_symbols ();
5019 gfc_warning_check ();
5020 st
= next_statement ();
5026 /* Parse the statements of an OpenMP structured block. */
5029 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
5031 gfc_statement st
, omp_end_st
;
5035 accept_statement (omp_st
);
5037 cp
= gfc_state_stack
->tail
;
5038 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5039 np
= new_level (cp
);
5045 case ST_OMP_PARALLEL
:
5046 omp_end_st
= ST_OMP_END_PARALLEL
;
5048 case ST_OMP_PARALLEL_SECTIONS
:
5049 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
5051 case ST_OMP_SECTIONS
:
5052 omp_end_st
= ST_OMP_END_SECTIONS
;
5054 case ST_OMP_ORDERED
:
5055 omp_end_st
= ST_OMP_END_ORDERED
;
5057 case ST_OMP_CRITICAL
:
5058 omp_end_st
= ST_OMP_END_CRITICAL
;
5061 omp_end_st
= ST_OMP_END_MASTER
;
5064 omp_end_st
= ST_OMP_END_SINGLE
;
5067 omp_end_st
= ST_OMP_END_TARGET
;
5069 case ST_OMP_TARGET_DATA
:
5070 omp_end_st
= ST_OMP_END_TARGET_DATA
;
5072 case ST_OMP_TARGET_TEAMS
:
5073 omp_end_st
= ST_OMP_END_TARGET_TEAMS
;
5075 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5076 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
5078 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5079 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5081 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5082 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5084 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5085 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
5088 omp_end_st
= ST_OMP_END_TASK
;
5090 case ST_OMP_TASKGROUP
:
5091 omp_end_st
= ST_OMP_END_TASKGROUP
;
5094 omp_end_st
= ST_OMP_END_TEAMS
;
5096 case ST_OMP_TEAMS_DISTRIBUTE
:
5097 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
5099 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5100 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5102 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5103 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5105 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5106 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
5108 case ST_OMP_DISTRIBUTE
:
5109 omp_end_st
= ST_OMP_END_DISTRIBUTE
;
5111 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5112 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
5114 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5115 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
5117 case ST_OMP_DISTRIBUTE_SIMD
:
5118 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
5120 case ST_OMP_WORKSHARE
:
5121 omp_end_st
= ST_OMP_END_WORKSHARE
;
5123 case ST_OMP_PARALLEL_WORKSHARE
:
5124 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
5132 if (workshare_stmts_only
)
5134 /* Inside of !$omp workshare, only
5137 where statements and constructs
5138 forall statements and constructs
5142 are allowed. For !$omp critical these
5143 restrictions apply recursively. */
5146 st
= next_statement ();
5157 accept_statement (st
);
5160 case ST_WHERE_BLOCK
:
5161 parse_where_block ();
5164 case ST_FORALL_BLOCK
:
5165 parse_forall_block ();
5168 case ST_OMP_PARALLEL
:
5169 case ST_OMP_PARALLEL_SECTIONS
:
5170 parse_omp_structured_block (st
, false);
5173 case ST_OMP_PARALLEL_WORKSHARE
:
5174 case ST_OMP_CRITICAL
:
5175 parse_omp_structured_block (st
, true);
5178 case ST_OMP_PARALLEL_DO
:
5179 case ST_OMP_PARALLEL_DO_SIMD
:
5180 st
= parse_omp_do (st
);
5184 st
= parse_omp_oacc_atomic (true);
5195 st
= next_statement ();
5199 st
= parse_executable (ST_NONE
);
5202 else if (st
== ST_OMP_SECTION
5203 && (omp_st
== ST_OMP_SECTIONS
5204 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
5206 np
= new_level (np
);
5210 else if (st
!= omp_end_st
)
5211 unexpected_statement (st
);
5213 while (st
!= omp_end_st
);
5217 case EXEC_OMP_END_NOWAIT
:
5218 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
5220 case EXEC_OMP_END_CRITICAL
:
5221 if (((cp
->ext
.omp_clauses
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
5222 || (new_st
.ext
.omp_name
!= NULL
5223 && strcmp (cp
->ext
.omp_clauses
->critical_name
,
5224 new_st
.ext
.omp_name
) != 0))
5225 gfc_error ("Name after !$omp critical and !$omp end critical does "
5227 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
5228 new_st
.ext
.omp_name
= NULL
;
5230 case EXEC_OMP_END_SINGLE
:
5231 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
5232 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
5233 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
5234 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
5242 gfc_clear_new_st ();
5243 gfc_commit_symbols ();
5244 gfc_warning_check ();
5249 /* Accept a series of executable statements. We return the first
5250 statement that doesn't fit to the caller. Any block statements are
5251 passed on to the correct handler, which usually passes the buck
5254 static gfc_statement
5255 parse_executable (gfc_statement st
)
5260 st
= next_statement ();
5264 close_flag
= check_do_closure ();
5269 case ST_END_PROGRAM
:
5272 case ST_END_FUNCTION
:
5277 case ST_END_SUBROUTINE
:
5282 case ST_SELECT_CASE
:
5283 gfc_error ("%s statement at %C cannot terminate a non-block "
5284 "DO loop", gfc_ascii_statement (st
));
5297 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
5298 "first executable statement");
5304 accept_statement (st
);
5305 if (close_flag
== 1)
5306 return ST_IMPLIED_ENDDO
;
5310 parse_block_construct ();
5321 case ST_SELECT_CASE
:
5322 parse_select_block ();
5325 case ST_SELECT_TYPE
:
5326 parse_select_type_block ();
5331 if (check_do_closure () == 1)
5332 return ST_IMPLIED_ENDDO
;
5336 parse_critical_block ();
5339 case ST_WHERE_BLOCK
:
5340 parse_where_block ();
5343 case ST_FORALL_BLOCK
:
5344 parse_forall_block ();
5347 case ST_OACC_PARALLEL_LOOP
:
5348 case ST_OACC_KERNELS_LOOP
:
5350 st
= parse_oacc_loop (st
);
5351 if (st
== ST_IMPLIED_ENDDO
)
5355 case ST_OACC_PARALLEL
:
5356 case ST_OACC_KERNELS
:
5358 case ST_OACC_HOST_DATA
:
5359 parse_oacc_structured_block (st
);
5362 case ST_OMP_PARALLEL
:
5363 case ST_OMP_PARALLEL_SECTIONS
:
5364 case ST_OMP_SECTIONS
:
5365 case ST_OMP_ORDERED
:
5366 case ST_OMP_CRITICAL
:
5370 case ST_OMP_TARGET_DATA
:
5371 case ST_OMP_TARGET_PARALLEL
:
5372 case ST_OMP_TARGET_TEAMS
:
5375 case ST_OMP_TASKGROUP
:
5376 parse_omp_structured_block (st
, false);
5379 case ST_OMP_WORKSHARE
:
5380 case ST_OMP_PARALLEL_WORKSHARE
:
5381 parse_omp_structured_block (st
, true);
5384 case ST_OMP_DISTRIBUTE
:
5385 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5386 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5387 case ST_OMP_DISTRIBUTE_SIMD
:
5389 case ST_OMP_DO_SIMD
:
5390 case ST_OMP_PARALLEL_DO
:
5391 case ST_OMP_PARALLEL_DO_SIMD
:
5393 case ST_OMP_TARGET_PARALLEL_DO
:
5394 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
5395 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5396 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5397 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5398 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5399 case ST_OMP_TASKLOOP
:
5400 case ST_OMP_TASKLOOP_SIMD
:
5401 case ST_OMP_TEAMS_DISTRIBUTE
:
5402 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5403 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5404 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5405 st
= parse_omp_do (st
);
5406 if (st
== ST_IMPLIED_ENDDO
)
5410 case ST_OACC_ATOMIC
:
5411 st
= parse_omp_oacc_atomic (false);
5415 st
= parse_omp_oacc_atomic (true);
5422 if (directive_unroll
!= -1)
5423 gfc_error ("%<GCC unroll%> directive does not commence a loop at %C");
5425 st
= next_statement ();
5430 /* Fix the symbols for sibling functions. These are incorrectly added to
5431 the child namespace as the parser didn't know about this procedure. */
5434 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
5438 gfc_symbol
*old_sym
;
5440 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
5442 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
5444 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
5445 goto fixup_contained
;
5447 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
5448 && sym
->attr
.generic
&& sym
->attr
.function
)
5449 ||(sym
->attr
.flavor
== FL_DERIVED
5450 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
5451 goto fixup_contained
;
5453 old_sym
= st
->n
.sym
;
5454 if (old_sym
->ns
== ns
5455 && !old_sym
->attr
.contained
5457 /* By 14.6.1.3, host association should be excluded
5458 for the following. */
5459 && !(old_sym
->attr
.external
5460 || (old_sym
->ts
.type
!= BT_UNKNOWN
5461 && !old_sym
->attr
.implicit_type
)
5462 || old_sym
->attr
.flavor
== FL_PARAMETER
5463 || old_sym
->attr
.use_assoc
5464 || old_sym
->attr
.in_common
5465 || old_sym
->attr
.in_equivalence
5466 || old_sym
->attr
.data
5467 || old_sym
->attr
.dummy
5468 || old_sym
->attr
.result
5469 || old_sym
->attr
.dimension
5470 || old_sym
->attr
.allocatable
5471 || old_sym
->attr
.intrinsic
5472 || old_sym
->attr
.generic
5473 || old_sym
->attr
.flavor
== FL_NAMELIST
5474 || old_sym
->attr
.flavor
== FL_LABEL
5475 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
5477 /* Replace it with the symbol from the parent namespace. */
5481 gfc_release_symbol (old_sym
);
5485 /* Do the same for any contained procedures. */
5486 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
5491 parse_contained (int module
)
5493 gfc_namespace
*ns
, *parent_ns
, *tmp
;
5494 gfc_state_data s1
, s2
;
5499 int contains_statements
= 0;
5502 push_state (&s1
, COMP_CONTAINS
, NULL
);
5503 parent_ns
= gfc_current_ns
;
5507 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
5509 gfc_current_ns
->sibling
= parent_ns
->contained
;
5510 parent_ns
->contained
= gfc_current_ns
;
5513 /* Process the next available statement. We come here if we got an error
5514 and rejected the last statement. */
5515 old_loc
= gfc_current_locus
;
5516 st
= next_statement ();
5525 contains_statements
= 1;
5526 accept_statement (st
);
5529 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
5532 /* For internal procedures, create/update the symbol in the
5533 parent namespace. */
5537 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
5538 gfc_error ("Contained procedure %qs at %C is already "
5539 "ambiguous", gfc_new_block
->name
);
5542 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
5544 &gfc_new_block
->declared_at
))
5546 if (st
== ST_FUNCTION
)
5547 gfc_add_function (&sym
->attr
, sym
->name
,
5548 &gfc_new_block
->declared_at
);
5550 gfc_add_subroutine (&sym
->attr
, sym
->name
,
5551 &gfc_new_block
->declared_at
);
5555 gfc_commit_symbols ();
5558 sym
= gfc_new_block
;
5560 /* Mark this as a contained function, so it isn't replaced
5561 by other module functions. */
5562 sym
->attr
.contained
= 1;
5564 /* Set implicit_pure so that it can be reset if any of the
5565 tests for purity fail. This is used for some optimisation
5566 during translation. */
5567 if (!sym
->attr
.pure
)
5568 sym
->attr
.implicit_pure
= 1;
5570 parse_progunit (ST_NONE
);
5572 /* Fix up any sibling functions that refer to this one. */
5573 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
5574 /* Or refer to any of its alternate entry points. */
5575 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
5576 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
5578 gfc_current_ns
->code
= s2
.head
;
5579 gfc_current_ns
= parent_ns
;
5584 /* These statements are associated with the end of the host unit. */
5585 case ST_END_FUNCTION
:
5587 case ST_END_SUBMODULE
:
5588 case ST_END_PROGRAM
:
5589 case ST_END_SUBROUTINE
:
5590 accept_statement (st
);
5591 gfc_current_ns
->code
= s1
.head
;
5595 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
5596 gfc_ascii_statement (st
));
5597 reject_statement ();
5603 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
5604 && st
!= ST_END_MODULE
&& st
!= ST_END_SUBMODULE
5605 && st
!= ST_END_PROGRAM
);
5607 /* The first namespace in the list is guaranteed to not have
5608 anything (worthwhile) in it. */
5609 tmp
= gfc_current_ns
;
5610 gfc_current_ns
= parent_ns
;
5611 if (seen_error
&& tmp
->refs
> 1)
5612 gfc_free_namespace (tmp
);
5614 ns
= gfc_current_ns
->contained
;
5615 gfc_current_ns
->contained
= ns
->sibling
;
5616 gfc_free_namespace (ns
);
5619 if (!contains_statements
)
5620 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
5621 "FUNCTION or SUBROUTINE statement at %L", &old_loc
);
5625 /* The result variable in a MODULE PROCEDURE needs to be created and
5626 its characteristics copied from the interface since it is neither
5627 declared in the procedure declaration nor in the specification
5631 get_modproc_result (void)
5634 if (gfc_state_stack
->previous
5635 && gfc_state_stack
->previous
->state
== COMP_CONTAINS
5636 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
5638 proc
= gfc_current_ns
->proc_name
? gfc_current_ns
->proc_name
: NULL
;
5640 && proc
->attr
.function
5642 && proc
->tlink
->result
5643 && proc
->tlink
->result
!= proc
->tlink
)
5645 gfc_copy_dummy_sym (&proc
->result
, proc
->tlink
->result
, 1);
5646 gfc_set_sym_referenced (proc
->result
);
5647 proc
->result
->attr
.if_source
= IFSRC_DECL
;
5648 gfc_commit_symbol (proc
->result
);
5654 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
5657 parse_progunit (gfc_statement st
)
5663 && gfc_new_block
->abr_modproc_decl
5664 && gfc_new_block
->attr
.function
)
5665 get_modproc_result ();
5667 st
= parse_spec (st
);
5674 /* This is not allowed within BLOCK! */
5675 if (gfc_current_state () != COMP_BLOCK
)
5680 accept_statement (st
);
5687 if (gfc_current_state () == COMP_FUNCTION
)
5688 gfc_check_function_type (gfc_current_ns
);
5693 st
= parse_executable (st
);
5701 /* This is not allowed within BLOCK! */
5702 if (gfc_current_state () != COMP_BLOCK
)
5707 accept_statement (st
);
5714 unexpected_statement (st
);
5715 reject_statement ();
5716 st
= next_statement ();
5722 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
5723 if (p
->state
== COMP_CONTAINS
)
5726 if (gfc_find_state (COMP_MODULE
) == true
5727 || gfc_find_state (COMP_SUBMODULE
) == true)
5732 gfc_error ("CONTAINS statement at %C is already in a contained "
5734 reject_statement ();
5735 st
= next_statement ();
5739 parse_contained (0);
5742 gfc_current_ns
->code
= gfc_state_stack
->head
;
5746 /* Come here to complain about a global symbol already in use as
5750 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
5755 where
= &gfc_current_locus
;
5765 case GSYM_SUBROUTINE
:
5766 name
= "SUBROUTINE";
5771 case GSYM_BLOCK_DATA
:
5772 name
= "BLOCK DATA";
5783 if (sym
->binding_label
)
5784 gfc_error ("Global binding name %qs at %L is already being used "
5785 "as a %s at %L", sym
->binding_label
, where
, name
,
5788 gfc_error ("Global name %qs at %L is already being used as "
5789 "a %s at %L", sym
->name
, where
, name
, &sym
->where
);
5793 if (sym
->binding_label
)
5794 gfc_error ("Global binding name %qs at %L is already being used "
5795 "at %L", sym
->binding_label
, where
, &sym
->where
);
5797 gfc_error ("Global name %qs at %L is already being used at %L",
5798 sym
->name
, where
, &sym
->where
);
5803 /* Parse a block data program unit. */
5806 parse_block_data (void)
5809 static locus blank_locus
;
5810 static int blank_block
=0;
5813 gfc_current_ns
->proc_name
= gfc_new_block
;
5814 gfc_current_ns
->is_block_data
= 1;
5816 if (gfc_new_block
== NULL
)
5819 gfc_error ("Blank BLOCK DATA at %C conflicts with "
5820 "prior BLOCK DATA at %L", &blank_locus
);
5824 blank_locus
= gfc_current_locus
;
5829 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5831 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
5832 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5835 s
->type
= GSYM_BLOCK_DATA
;
5836 s
->where
= gfc_new_block
->declared_at
;
5841 st
= parse_spec (ST_NONE
);
5843 while (st
!= ST_END_BLOCK_DATA
)
5845 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
5846 gfc_ascii_statement (st
));
5847 reject_statement ();
5848 st
= next_statement ();
5853 /* Following the association of the ancestor (sub)module symbols, they
5854 must be set host rather than use associated and all must be public.
5855 They are flagged up by 'used_in_submodule' so that they can be set
5856 DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
5857 linker chokes on multiple symbol definitions. */
5860 set_syms_host_assoc (gfc_symbol
*sym
)
5863 const char dot
[2] = ".";
5864 char parent1
[GFC_MAX_SYMBOL_LEN
+ 1];
5865 char parent2
[GFC_MAX_SYMBOL_LEN
+ 1];
5870 if (sym
->attr
.module_procedure
)
5871 sym
->attr
.external
= 0;
5873 sym
->attr
.use_assoc
= 0;
5874 sym
->attr
.host_assoc
= 1;
5875 sym
->attr
.used_in_submodule
=1;
5877 if (sym
->attr
.flavor
== FL_DERIVED
)
5879 /* Derived types with PRIVATE components that are declared in
5880 modules other than the parent module must not be changed to be
5881 PUBLIC. The 'use-assoc' attribute must be reset so that the
5882 test in symbol.c(gfc_find_component) works correctly. This is
5883 not necessary for PRIVATE symbols since they are not read from
5885 memset(parent1
, '\0', sizeof(parent1
));
5886 memset(parent2
, '\0', sizeof(parent2
));
5887 strcpy (parent1
, gfc_new_block
->name
);
5888 strcpy (parent2
, sym
->module
);
5889 if (strcmp (strtok (parent1
, dot
), strtok (parent2
, dot
)) == 0)
5891 for (c
= sym
->components
; c
; c
= c
->next
)
5892 c
->attr
.access
= ACCESS_PUBLIC
;
5896 sym
->attr
.use_assoc
= 1;
5897 sym
->attr
.host_assoc
= 0;
5902 /* Parse a module subprogram. */
5911 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5912 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
5913 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5916 s
->type
= GSYM_MODULE
;
5917 s
->where
= gfc_new_block
->declared_at
;
5921 /* Something is nulling the module_list after this point. This is good
5922 since it allows us to 'USE' the parent modules that the submodule
5923 inherits and to set (most) of the symbols as host associated. */
5924 if (gfc_current_state () == COMP_SUBMODULE
)
5927 gfc_traverse_ns (gfc_current_ns
, set_syms_host_assoc
);
5930 st
= parse_spec (ST_NONE
);
5940 parse_contained (1);
5944 case ST_END_SUBMODULE
:
5945 accept_statement (st
);
5949 gfc_error ("Unexpected %s statement in MODULE at %C",
5950 gfc_ascii_statement (st
));
5953 reject_statement ();
5954 st
= next_statement ();
5958 /* Make sure not to free the namespace twice on error. */
5960 s
->ns
= gfc_current_ns
;
5964 /* Add a procedure name to the global symbol table. */
5967 add_global_procedure (bool sub
)
5971 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5972 name is a global identifier. */
5973 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5975 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5978 || (s
->type
!= GSYM_UNKNOWN
5979 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5981 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5982 /* Silence follow-up errors. */
5983 gfc_new_block
->binding_label
= NULL
;
5987 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5988 s
->sym_name
= gfc_new_block
->name
;
5989 s
->where
= gfc_new_block
->declared_at
;
5991 s
->ns
= gfc_current_ns
;
5995 /* Don't add the symbol multiple times. */
5996 if (gfc_new_block
->binding_label
5997 && (!gfc_notification_std (GFC_STD_F2008
)
5998 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
6000 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
);
6003 || (s
->type
!= GSYM_UNKNOWN
6004 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
6006 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6007 /* Silence follow-up errors. */
6008 gfc_new_block
->binding_label
= NULL
;
6012 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6013 s
->sym_name
= gfc_new_block
->name
;
6014 s
->binding_label
= gfc_new_block
->binding_label
;
6015 s
->where
= gfc_new_block
->declared_at
;
6017 s
->ns
= gfc_current_ns
;
6023 /* Add a program to the global symbol table. */
6026 add_global_program (void)
6030 if (gfc_new_block
== NULL
)
6032 s
= gfc_get_gsymbol (gfc_new_block
->name
);
6034 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
6035 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6038 s
->type
= GSYM_PROGRAM
;
6039 s
->where
= gfc_new_block
->declared_at
;
6041 s
->ns
= gfc_current_ns
;
6046 /* Resolve all the program units. */
6048 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
6050 gfc_free_dt_list ();
6051 gfc_current_ns
= gfc_global_ns_list
;
6052 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6054 if (gfc_current_ns
->proc_name
6055 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6056 continue; /* Already resolved. */
6058 if (gfc_current_ns
->proc_name
)
6059 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6060 gfc_resolve (gfc_current_ns
);
6061 gfc_current_ns
->derived_types
= gfc_derived_types
;
6062 gfc_derived_types
= NULL
;
6068 clean_up_modules (gfc_gsymbol
*gsym
)
6073 clean_up_modules (gsym
->left
);
6074 clean_up_modules (gsym
->right
);
6076 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
6079 gfc_current_ns
= gsym
->ns
;
6080 gfc_derived_types
= gfc_current_ns
->derived_types
;
6087 /* Translate all the program units. This could be in a different order
6088 to resolution if there are forward references in the file. */
6090 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
6094 gfc_current_ns
= gfc_global_ns_list
;
6095 gfc_get_errors (NULL
, &errors
);
6097 /* We first translate all modules to make sure that later parts
6098 of the program can use the decl. Then we translate the nonmodules. */
6100 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6102 if (!gfc_current_ns
->proc_name
6103 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6106 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6107 gfc_derived_types
= gfc_current_ns
->derived_types
;
6108 gfc_generate_module_code (gfc_current_ns
);
6109 gfc_current_ns
->translated
= 1;
6112 gfc_current_ns
= gfc_global_ns_list
;
6113 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6115 if (gfc_current_ns
->proc_name
6116 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6119 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6120 gfc_derived_types
= gfc_current_ns
->derived_types
;
6121 gfc_generate_code (gfc_current_ns
);
6122 gfc_current_ns
->translated
= 1;
6125 /* Clean up all the namespaces after translation. */
6126 gfc_current_ns
= gfc_global_ns_list
;
6127 for (;gfc_current_ns
;)
6131 if (gfc_current_ns
->proc_name
6132 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6134 gfc_current_ns
= gfc_current_ns
->sibling
;
6138 ns
= gfc_current_ns
->sibling
;
6139 gfc_derived_types
= gfc_current_ns
->derived_types
;
6141 gfc_current_ns
= ns
;
6144 clean_up_modules (gfc_gsym_root
);
6148 /* Top level parser. */
6151 gfc_parse_file (void)
6153 int seen_program
, errors_before
, errors
;
6154 gfc_state_data top
, s
;
6157 gfc_namespace
*next
;
6159 gfc_start_source_files ();
6161 top
.state
= COMP_NONE
;
6163 top
.previous
= NULL
;
6164 top
.head
= top
.tail
= NULL
;
6165 top
.do_variable
= NULL
;
6167 gfc_state_stack
= &top
;
6169 gfc_clear_new_st ();
6171 gfc_statement_label
= NULL
;
6173 if (setjmp (eof_buf
))
6174 return false; /* Come here on unexpected EOF */
6176 /* Prepare the global namespace that will contain the
6178 gfc_global_ns_list
= next
= NULL
;
6183 /* Exit early for empty files. */
6187 in_specification_block
= true;
6190 st
= next_statement ();
6199 goto duplicate_main
;
6201 prog_locus
= gfc_current_locus
;
6203 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
6204 main_program_symbol (gfc_current_ns
, gfc_new_block
->name
);
6205 accept_statement (st
);
6206 add_global_program ();
6207 parse_progunit (ST_NONE
);
6211 add_global_procedure (true);
6212 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
6213 accept_statement (st
);
6214 parse_progunit (ST_NONE
);
6218 add_global_procedure (false);
6219 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
6220 accept_statement (st
);
6221 parse_progunit (ST_NONE
);
6225 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
6226 accept_statement (st
);
6227 parse_block_data ();
6231 push_state (&s
, COMP_MODULE
, gfc_new_block
);
6232 accept_statement (st
);
6234 gfc_get_errors (NULL
, &errors_before
);
6239 push_state (&s
, COMP_SUBMODULE
, gfc_new_block
);
6240 accept_statement (st
);
6242 gfc_get_errors (NULL
, &errors_before
);
6246 /* Anything else starts a nameless main program block. */
6249 goto duplicate_main
;
6251 prog_locus
= gfc_current_locus
;
6253 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
6254 main_program_symbol (gfc_current_ns
, "MAIN__");
6255 parse_progunit (st
);
6259 /* Handle the non-program units. */
6260 gfc_current_ns
->code
= s
.head
;
6262 gfc_resolve (gfc_current_ns
);
6264 /* Dump the parse tree if requested. */
6265 if (flag_dump_fortran_original
)
6266 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6268 if (flag_c_prototypes
)
6269 gfc_dump_c_prototypes (gfc_current_ns
, stdout
);
6271 gfc_get_errors (NULL
, &errors
);
6272 if (s
.state
== COMP_MODULE
|| s
.state
== COMP_SUBMODULE
)
6274 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
6275 gfc_current_ns
->derived_types
= gfc_derived_types
;
6276 gfc_derived_types
= NULL
;
6282 gfc_generate_code (gfc_current_ns
);
6290 /* The main program and non-contained procedures are put
6291 in the global namespace list, so that they can be processed
6292 later and all their interfaces resolved. */
6293 gfc_current_ns
->code
= s
.head
;
6296 for (; next
->sibling
; next
= next
->sibling
)
6298 next
->sibling
= gfc_current_ns
;
6301 gfc_global_ns_list
= gfc_current_ns
;
6303 next
= gfc_current_ns
;
6309 /* Do the resolution. */
6310 resolve_all_program_units (gfc_global_ns_list
);
6312 /* Do the parse tree dump. */
6313 gfc_current_ns
= flag_dump_fortran_original
? gfc_global_ns_list
: NULL
;
6315 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6316 if (!gfc_current_ns
->proc_name
6317 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6319 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6320 fputs ("------------------------------------------\n\n", stdout
);
6323 /* Do the translation. */
6324 translate_all_program_units (gfc_global_ns_list
);
6326 gfc_end_source_files ();
6330 /* If we see a duplicate main program, shut down. If the second
6331 instance is an implied main program, i.e. data decls or executable
6332 statements, we're in for lots of errors. */
6333 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
6334 reject_statement ();
6339 /* Return true if this state data represents an OpenACC region. */
6341 is_oacc (gfc_state_data
*sd
)
6343 switch (sd
->construct
->op
)
6345 case EXEC_OACC_PARALLEL_LOOP
:
6346 case EXEC_OACC_PARALLEL
:
6347 case EXEC_OACC_KERNELS_LOOP
:
6348 case EXEC_OACC_KERNELS
:
6349 case EXEC_OACC_DATA
:
6350 case EXEC_OACC_HOST_DATA
:
6351 case EXEC_OACC_LOOP
:
6352 case EXEC_OACC_UPDATE
:
6353 case EXEC_OACC_WAIT
:
6354 case EXEC_OACC_CACHE
:
6355 case EXEC_OACC_ENTER_DATA
:
6356 case EXEC_OACC_EXIT_DATA
:
6357 case EXEC_OACC_ATOMIC
:
6358 case EXEC_OACC_ROUTINE
: