2 Copyright (C) 2000-2015 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
24 #include "coretypes.h"
31 /* Current statement label. Zero means no statement label. Because new_st
32 can get wiped during statement matching, we have to keep it separate. */
34 gfc_st_label
*gfc_statement_label
;
36 static locus label_locus
;
37 static jmp_buf eof_buf
;
39 gfc_state_data
*gfc_state_stack
;
40 static bool last_was_use_stmt
= false;
42 /* TODO: Re-order functions to kill these forward decls. */
43 static void check_statement_label (gfc_statement
);
44 static void undo_new_statement (void);
45 static void reject_statement (void);
48 /* A sort of half-matching function. We try to match the word on the
49 input with the passed string. If this succeeds, we call the
50 keyword-dependent matching function that will match the rest of the
51 statement. For single keywords, the matching subroutine is
55 match_word (const char *str
, match (*subr
) (void), locus
*old_locus
)
70 gfc_current_locus
= *old_locus
;
78 /* Like match_word, but if str is matched, set a flag that it
81 match_word_omp_simd (const char *str
, match (*subr
) (void), locus
*old_locus
,
98 gfc_current_locus
= *old_locus
;
106 /* Load symbols from all USE statements encountered in this scoping unit. */
111 gfc_error_buffer old_error
;
113 gfc_push_error (&old_error
);
114 gfc_buffer_error (false);
116 gfc_buffer_error (true);
117 gfc_pop_error (&old_error
);
118 gfc_commit_symbols ();
119 gfc_warning_check ();
120 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
121 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
122 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
123 last_was_use_stmt
= false;
127 /* Figure out what the next statement is, (mostly) regardless of
128 proper ordering. The do...while(0) is there to prevent if/else
131 #define match(keyword, subr, st) \
133 if (match_word (keyword, subr, &old_locus) == MATCH_YES) \
136 undo_new_statement (); \
140 /* This is a specialist version of decode_statement that is used
141 for the specification statements in a function, whose
142 characteristics are deferred into the specification statements.
143 eg.: INTEGER (king = mykind) foo ()
144 USE mymodule, ONLY mykind.....
145 The KIND parameter needs a return after USE or IMPORT, whereas
146 derived type declarations can occur anywhere, up the executable
147 block. ST_GET_FCN_CHARACTERISTICS is returned when we have run
148 out of the correct kind of specification statements. */
150 decode_specification_statement (void)
156 if (gfc_match_eos () == MATCH_YES
)
159 old_locus
= gfc_current_locus
;
161 if (match_word ("use", gfc_match_use
, &old_locus
) == MATCH_YES
)
163 last_was_use_stmt
= true;
168 undo_new_statement ();
169 if (last_was_use_stmt
)
173 match ("import", gfc_match_import
, ST_IMPORT
);
175 if (gfc_current_block ()->result
->ts
.type
!= BT_DERIVED
)
178 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
179 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
180 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
182 /* General statement matching: Instead of testing every possible
183 statement, we eliminate most possibilities by peeking at the
186 c
= gfc_peek_ascii_char ();
191 match ("abstract% interface", gfc_match_abstract_interface
,
193 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
194 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
198 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
202 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
203 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
207 match ("data", gfc_match_data
, ST_DATA
);
208 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
212 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
213 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
214 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
215 match ("external", gfc_match_external
, ST_ATTR_DECL
);
219 match ("format", gfc_match_format
, ST_FORMAT
);
226 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
227 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
228 match ("interface", gfc_match_interface
, ST_INTERFACE
);
229 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
230 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
237 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
241 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
245 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
246 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
247 if (gfc_match_private (&st
) == MATCH_YES
)
249 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
250 if (gfc_match_public (&st
) == MATCH_YES
)
252 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
259 match ("save", gfc_match_save
, ST_ATTR_DECL
);
263 match ("target", gfc_match_target
, ST_ATTR_DECL
);
264 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
271 match ("value", gfc_match_value
, ST_ATTR_DECL
);
272 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
279 /* This is not a specification statement. See if any of the matchers
280 has stored an error message of some sort. */
284 gfc_buffer_error (false);
285 gfc_current_locus
= old_locus
;
287 return ST_GET_FCN_CHARACTERISTICS
;
291 /* This is the primary 'decode_statement'. */
293 decode_statement (void)
301 gfc_enforce_clean_symbol_state ();
303 gfc_clear_error (); /* Clear any pending errors. */
304 gfc_clear_warning (); /* Clear any pending warnings. */
306 gfc_matching_function
= false;
308 if (gfc_match_eos () == MATCH_YES
)
311 if (gfc_current_state () == COMP_FUNCTION
312 && gfc_current_block ()->result
->ts
.kind
== -1)
313 return decode_specification_statement ();
315 old_locus
= gfc_current_locus
;
317 c
= gfc_peek_ascii_char ();
321 if (match_word ("use", gfc_match_use
, &old_locus
) == MATCH_YES
)
323 last_was_use_stmt
= true;
327 undo_new_statement ();
330 if (last_was_use_stmt
)
333 /* Try matching a data declaration or function declaration. The
334 input "REALFUNCTIONA(N)" can mean several things in different
335 contexts, so it (and its relatives) get special treatment. */
337 if (gfc_current_state () == COMP_NONE
338 || gfc_current_state () == COMP_INTERFACE
339 || gfc_current_state () == COMP_CONTAINS
)
341 gfc_matching_function
= true;
342 m
= gfc_match_function_decl ();
345 else if (m
== MATCH_ERROR
)
349 gfc_current_locus
= old_locus
;
351 gfc_matching_function
= false;
354 /* Match statements whose error messages are meant to be overwritten
355 by something better. */
357 match (NULL
, gfc_match_assignment
, ST_ASSIGNMENT
);
358 match (NULL
, gfc_match_pointer_assignment
, ST_POINTER_ASSIGNMENT
);
359 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
361 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
362 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
364 /* Try to match a subroutine statement, which has the same optional
365 prefixes that functions can have. */
367 if (gfc_match_subroutine () == MATCH_YES
)
368 return ST_SUBROUTINE
;
370 gfc_current_locus
= old_locus
;
372 /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
373 statements, which might begin with a block label. The match functions for
374 these statements are unusual in that their keyword is not seen before
375 the matcher is called. */
377 if (gfc_match_if (&st
) == MATCH_YES
)
380 gfc_current_locus
= old_locus
;
382 if (gfc_match_where (&st
) == MATCH_YES
)
385 gfc_current_locus
= old_locus
;
387 if (gfc_match_forall (&st
) == MATCH_YES
)
390 gfc_current_locus
= old_locus
;
392 match (NULL
, gfc_match_do
, ST_DO
);
393 match (NULL
, gfc_match_block
, ST_BLOCK
);
394 match (NULL
, gfc_match_associate
, ST_ASSOCIATE
);
395 match (NULL
, gfc_match_critical
, ST_CRITICAL
);
396 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
398 gfc_current_ns
= gfc_build_block_ns (gfc_current_ns
);
399 match (NULL
, gfc_match_select_type
, ST_SELECT_TYPE
);
401 gfc_current_ns
= gfc_current_ns
->parent
;
402 gfc_free_namespace (ns
);
404 /* General statement matching: Instead of testing every possible
405 statement, we eliminate most possibilities by peeking at the
411 match ("abstract% interface", gfc_match_abstract_interface
,
413 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
414 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
415 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
416 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
420 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
421 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
422 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
426 match ("call", gfc_match_call
, ST_CALL
);
427 match ("close", gfc_match_close
, ST_CLOSE
);
428 match ("continue", gfc_match_continue
, ST_CONTINUE
);
429 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
430 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
431 match ("case", gfc_match_case
, ST_CASE
);
432 match ("common", gfc_match_common
, ST_COMMON
);
433 match ("contains", gfc_match_eos
, ST_CONTAINS
);
434 match ("class", gfc_match_class_is
, ST_CLASS_IS
);
435 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
439 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
440 match ("data", gfc_match_data
, ST_DATA
);
441 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
445 match ("end file", gfc_match_endfile
, ST_END_FILE
);
446 match ("exit", gfc_match_exit
, ST_EXIT
);
447 match ("else", gfc_match_else
, ST_ELSE
);
448 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
449 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
450 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
);
451 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
453 if (gfc_match_end (&st
) == MATCH_YES
)
456 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
457 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
458 match ("external", gfc_match_external
, ST_ATTR_DECL
);
462 match ("final", gfc_match_final_decl
, ST_FINAL
);
463 match ("flush", gfc_match_flush
, ST_FLUSH
);
464 match ("format", gfc_match_format
, ST_FORMAT
);
468 match ("generic", gfc_match_generic
, ST_GENERIC
);
469 match ("go to", gfc_match_goto
, ST_GOTO
);
473 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
474 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
475 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
476 match ("import", gfc_match_import
, ST_IMPORT
);
477 match ("interface", gfc_match_interface
, ST_INTERFACE
);
478 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
479 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
483 match ("lock", gfc_match_lock
, ST_LOCK
);
487 match ("module% procedure", gfc_match_modproc
, ST_MODULE_PROC
);
488 match ("module", gfc_match_module
, ST_MODULE
);
492 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
493 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
497 match ("open", gfc_match_open
, ST_OPEN
);
498 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
502 match ("print", gfc_match_print
, ST_WRITE
);
503 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
504 match ("pause", gfc_match_pause
, ST_PAUSE
);
505 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
506 if (gfc_match_private (&st
) == MATCH_YES
)
508 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
509 match ("program", gfc_match_program
, ST_PROGRAM
);
510 if (gfc_match_public (&st
) == MATCH_YES
)
512 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
516 match ("read", gfc_match_read
, ST_READ
);
517 match ("return", gfc_match_return
, ST_RETURN
);
518 match ("rewind", gfc_match_rewind
, ST_REWIND
);
522 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
523 match ("stop", gfc_match_stop
, ST_STOP
);
524 match ("save", gfc_match_save
, ST_ATTR_DECL
);
525 match ("sync all", gfc_match_sync_all
, ST_SYNC_ALL
);
526 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
527 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
531 match ("target", gfc_match_target
, ST_ATTR_DECL
);
532 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
533 match ("type is", gfc_match_type_is
, ST_TYPE_IS
);
537 match ("unlock", gfc_match_unlock
, ST_UNLOCK
);
541 match ("value", gfc_match_value
, ST_ATTR_DECL
);
542 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
546 match ("wait", gfc_match_wait
, ST_WAIT
);
547 match ("write", gfc_match_write
, ST_WRITE
);
551 /* All else has failed, so give up. See if any of the matchers has
552 stored an error message of some sort. */
554 if (!gfc_error_check ())
555 gfc_error_now ("Unclassifiable statement at %C");
559 gfc_error_recovery ();
564 /* Like match, but set a flag simd_matched if keyword matched. */
565 #define matchs(keyword, subr, st) \
567 if (match_word_omp_simd (keyword, subr, &old_locus, \
568 &simd_matched) == MATCH_YES) \
571 undo_new_statement (); \
574 /* Like match, but don't match anything if not -fopenmp. */
575 #define matcho(keyword, subr, st) \
579 else if (match_word (keyword, subr, &old_locus) \
583 undo_new_statement (); \
587 decode_oacc_directive (void)
592 gfc_enforce_clean_symbol_state ();
594 gfc_clear_error (); /* Clear any pending errors. */
595 gfc_clear_warning (); /* Clear any pending warnings. */
599 gfc_error_now ("OpenACC directives at %C may not appear in PURE "
601 gfc_error_recovery ();
605 gfc_unset_implicit_pure (NULL
);
607 old_locus
= gfc_current_locus
;
609 /* General OpenACC directive matching: Instead of testing every possible
610 statement, we eliminate most possibilities by peeking at the
613 c
= gfc_peek_ascii_char ();
618 match ("cache", gfc_match_oacc_cache
, ST_OACC_CACHE
);
621 match ("data", gfc_match_oacc_data
, ST_OACC_DATA
);
622 match ("declare", gfc_match_oacc_declare
, ST_OACC_DECLARE
);
625 match ("end data", gfc_match_omp_eos
, ST_OACC_END_DATA
);
626 match ("end host_data", gfc_match_omp_eos
, ST_OACC_END_HOST_DATA
);
627 match ("end kernels loop", gfc_match_omp_eos
, ST_OACC_END_KERNELS_LOOP
);
628 match ("end kernels", gfc_match_omp_eos
, ST_OACC_END_KERNELS
);
629 match ("end loop", gfc_match_omp_eos
, ST_OACC_END_LOOP
);
630 match ("end parallel loop", gfc_match_omp_eos
, ST_OACC_END_PARALLEL_LOOP
);
631 match ("end parallel", gfc_match_omp_eos
, ST_OACC_END_PARALLEL
);
632 match ("enter data", gfc_match_oacc_enter_data
, ST_OACC_ENTER_DATA
);
633 match ("exit data", gfc_match_oacc_exit_data
, ST_OACC_EXIT_DATA
);
636 match ("host_data", gfc_match_oacc_host_data
, ST_OACC_HOST_DATA
);
639 match ("parallel loop", gfc_match_oacc_parallel_loop
, ST_OACC_PARALLEL_LOOP
);
640 match ("parallel", gfc_match_oacc_parallel
, ST_OACC_PARALLEL
);
643 match ("kernels loop", gfc_match_oacc_kernels_loop
, ST_OACC_KERNELS_LOOP
);
644 match ("kernels", gfc_match_oacc_kernels
, ST_OACC_KERNELS
);
647 match ("loop", gfc_match_oacc_loop
, ST_OACC_LOOP
);
650 match ("routine", gfc_match_oacc_routine
, ST_OACC_ROUTINE
);
653 match ("update", gfc_match_oacc_update
, ST_OACC_UPDATE
);
656 match ("wait", gfc_match_oacc_wait
, ST_OACC_WAIT
);
660 /* Directive not found or stored an error message.
661 Check and give up. */
663 if (gfc_error_check () == 0)
664 gfc_error_now ("Unclassifiable OpenACC directive at %C");
668 gfc_error_recovery ();
674 decode_omp_directive (void)
678 bool simd_matched
= false;
680 gfc_enforce_clean_symbol_state ();
682 gfc_clear_error (); /* Clear any pending errors. */
683 gfc_clear_warning (); /* Clear any pending warnings. */
687 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
688 "or ELEMENTAL procedures");
689 gfc_error_recovery ();
693 gfc_unset_implicit_pure (NULL
);
695 old_locus
= gfc_current_locus
;
697 /* General OpenMP directive matching: Instead of testing every possible
698 statement, we eliminate most possibilities by peeking at the
701 c
= gfc_peek_ascii_char ();
703 /* match is for directives that should be recognized only if
704 -fopenmp, matchs for directives that should be recognized
705 if either -fopenmp or -fopenmp-simd. */
709 matcho ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
712 matcho ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
715 matcho ("cancellation% point", gfc_match_omp_cancellation_point
,
716 ST_OMP_CANCELLATION_POINT
);
717 matcho ("cancel", gfc_match_omp_cancel
, ST_OMP_CANCEL
);
718 matcho ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
721 matchs ("declare reduction", gfc_match_omp_declare_reduction
,
722 ST_OMP_DECLARE_REDUCTION
);
723 matchs ("declare simd", gfc_match_omp_declare_simd
,
724 ST_OMP_DECLARE_SIMD
);
725 matcho ("declare target", gfc_match_omp_declare_target
,
726 ST_OMP_DECLARE_TARGET
);
727 matchs ("distribute parallel do simd",
728 gfc_match_omp_distribute_parallel_do_simd
,
729 ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
);
730 matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do
,
731 ST_OMP_DISTRIBUTE_PARALLEL_DO
);
732 matchs ("distribute simd", gfc_match_omp_distribute_simd
,
733 ST_OMP_DISTRIBUTE_SIMD
);
734 matcho ("distribute", gfc_match_omp_distribute
, ST_OMP_DISTRIBUTE
);
735 matchs ("do simd", gfc_match_omp_do_simd
, ST_OMP_DO_SIMD
);
736 matcho ("do", gfc_match_omp_do
, ST_OMP_DO
);
739 matcho ("end atomic", gfc_match_omp_eos
, ST_OMP_END_ATOMIC
);
740 matcho ("end critical", gfc_match_omp_critical
, ST_OMP_END_CRITICAL
);
741 matchs ("end distribute parallel do simd", gfc_match_omp_eos
,
742 ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
);
743 matcho ("end distribute parallel do", gfc_match_omp_eos
,
744 ST_OMP_END_DISTRIBUTE_PARALLEL_DO
);
745 matchs ("end distribute simd", gfc_match_omp_eos
,
746 ST_OMP_END_DISTRIBUTE_SIMD
);
747 matcho ("end distribute", gfc_match_omp_eos
, ST_OMP_END_DISTRIBUTE
);
748 matchs ("end do simd", gfc_match_omp_end_nowait
, ST_OMP_END_DO_SIMD
);
749 matcho ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
750 matchs ("end simd", gfc_match_omp_eos
, ST_OMP_END_SIMD
);
751 matcho ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
752 matcho ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
753 matchs ("end parallel do simd", gfc_match_omp_eos
,
754 ST_OMP_END_PARALLEL_DO_SIMD
);
755 matcho ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
756 matcho ("end parallel sections", gfc_match_omp_eos
,
757 ST_OMP_END_PARALLEL_SECTIONS
);
758 matcho ("end parallel workshare", gfc_match_omp_eos
,
759 ST_OMP_END_PARALLEL_WORKSHARE
);
760 matcho ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
761 matcho ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
762 matcho ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
763 matcho ("end target data", gfc_match_omp_eos
, ST_OMP_END_TARGET_DATA
);
764 matchs ("end target teams distribute parallel do simd",
766 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
767 matcho ("end target teams distribute parallel do", gfc_match_omp_eos
,
768 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
769 matchs ("end target teams distribute simd", gfc_match_omp_eos
,
770 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
);
771 matcho ("end target teams distribute", gfc_match_omp_eos
,
772 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
);
773 matcho ("end target teams", gfc_match_omp_eos
, ST_OMP_END_TARGET_TEAMS
);
774 matcho ("end target", gfc_match_omp_eos
, ST_OMP_END_TARGET
);
775 matcho ("end taskgroup", gfc_match_omp_eos
, ST_OMP_END_TASKGROUP
);
776 matcho ("end task", gfc_match_omp_eos
, ST_OMP_END_TASK
);
777 matchs ("end teams distribute parallel do simd", gfc_match_omp_eos
,
778 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
779 matcho ("end teams distribute parallel do", gfc_match_omp_eos
,
780 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
);
781 matchs ("end teams distribute simd", gfc_match_omp_eos
,
782 ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
);
783 matcho ("end teams distribute", gfc_match_omp_eos
,
784 ST_OMP_END_TEAMS_DISTRIBUTE
);
785 matcho ("end teams", gfc_match_omp_eos
, ST_OMP_END_TEAMS
);
786 matcho ("end workshare", gfc_match_omp_end_nowait
,
787 ST_OMP_END_WORKSHARE
);
790 matcho ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
793 matcho ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
796 matcho ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
799 matchs ("parallel do simd", gfc_match_omp_parallel_do_simd
,
800 ST_OMP_PARALLEL_DO_SIMD
);
801 matcho ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
802 matcho ("parallel sections", gfc_match_omp_parallel_sections
,
803 ST_OMP_PARALLEL_SECTIONS
);
804 matcho ("parallel workshare", gfc_match_omp_parallel_workshare
,
805 ST_OMP_PARALLEL_WORKSHARE
);
806 matcho ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
809 matcho ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
810 matcho ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
811 matchs ("simd", gfc_match_omp_simd
, ST_OMP_SIMD
);
812 matcho ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
815 matcho ("target data", gfc_match_omp_target_data
, ST_OMP_TARGET_DATA
);
816 matchs ("target teams distribute parallel do simd",
817 gfc_match_omp_target_teams_distribute_parallel_do_simd
,
818 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
819 matcho ("target teams distribute parallel do",
820 gfc_match_omp_target_teams_distribute_parallel_do
,
821 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
822 matchs ("target teams distribute simd",
823 gfc_match_omp_target_teams_distribute_simd
,
824 ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
);
825 matcho ("target teams distribute", gfc_match_omp_target_teams_distribute
,
826 ST_OMP_TARGET_TEAMS_DISTRIBUTE
);
827 matcho ("target teams", gfc_match_omp_target_teams
, ST_OMP_TARGET_TEAMS
);
828 matcho ("target update", gfc_match_omp_target_update
,
829 ST_OMP_TARGET_UPDATE
);
830 matcho ("target", gfc_match_omp_target
, ST_OMP_TARGET
);
831 matcho ("taskgroup", gfc_match_omp_taskgroup
, ST_OMP_TASKGROUP
);
832 matcho ("taskwait", gfc_match_omp_taskwait
, ST_OMP_TASKWAIT
);
833 matcho ("taskyield", gfc_match_omp_taskyield
, ST_OMP_TASKYIELD
);
834 matcho ("task", gfc_match_omp_task
, ST_OMP_TASK
);
835 matchs ("teams distribute parallel do simd",
836 gfc_match_omp_teams_distribute_parallel_do_simd
,
837 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
838 matcho ("teams distribute parallel do",
839 gfc_match_omp_teams_distribute_parallel_do
,
840 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
);
841 matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd
,
842 ST_OMP_TEAMS_DISTRIBUTE_SIMD
);
843 matcho ("teams distribute", gfc_match_omp_teams_distribute
,
844 ST_OMP_TEAMS_DISTRIBUTE
);
845 matcho ("teams", gfc_match_omp_teams
, ST_OMP_TEAMS
);
846 matcho ("threadprivate", gfc_match_omp_threadprivate
,
847 ST_OMP_THREADPRIVATE
);
850 matcho ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
854 /* All else has failed, so give up. See if any of the matchers has
855 stored an error message of some sort. Don't error out if
856 not -fopenmp and simd_matched is false, i.e. if a directive other
857 than one marked with match has been seen. */
859 if (flag_openmp
|| simd_matched
)
861 if (!gfc_error_check ())
862 gfc_error_now ("Unclassifiable OpenMP directive at %C");
867 gfc_error_recovery ();
873 decode_gcc_attribute (void)
877 gfc_enforce_clean_symbol_state ();
879 gfc_clear_error (); /* Clear any pending errors. */
880 gfc_clear_warning (); /* Clear any pending warnings. */
881 old_locus
= gfc_current_locus
;
883 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
885 /* All else has failed, so give up. See if any of the matchers has
886 stored an error message of some sort. */
888 if (!gfc_error_check ())
889 gfc_error_now ("Unclassifiable GCC directive at %C");
893 gfc_error_recovery ();
900 /* Assert next length characters to be equal to token in free form. */
903 verify_token_free (const char* token
, int length
, bool last_was_use_stmt
)
908 c
= gfc_next_ascii_char ();
909 for (i
= 0; i
< length
; i
++, c
= gfc_next_ascii_char ())
910 gcc_assert (c
== token
[i
]);
912 gcc_assert (gfc_is_whitespace(c
));
913 gfc_gobble_whitespace ();
914 if (last_was_use_stmt
)
918 /* Get the next statement in free form source. */
927 at_bol
= gfc_at_bol ();
928 gfc_gobble_whitespace ();
930 c
= gfc_peek_ascii_char ();
936 /* Found a statement label? */
937 m
= gfc_match_st_label (&gfc_statement_label
);
939 d
= gfc_peek_ascii_char ();
940 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
942 gfc_match_small_literal_int (&i
, &cnt
);
945 gfc_error_now ("Too many digits in statement label at %C");
948 gfc_error_now ("Zero is not a valid statement label at %C");
951 c
= gfc_next_ascii_char ();
954 if (!gfc_is_whitespace (c
))
955 gfc_error_now ("Non-numeric character in statement label at %C");
961 label_locus
= gfc_current_locus
;
963 gfc_gobble_whitespace ();
965 if (at_bol
&& gfc_peek_ascii_char () == ';')
967 gfc_error_now ("Semicolon at %C needs to be preceded by "
969 gfc_next_ascii_char (); /* Eat up the semicolon. */
973 if (gfc_match_eos () == MATCH_YES
)
975 gfc_warning_now (0, "Ignoring statement label in empty statement "
976 "at %L", &label_locus
);
977 gfc_free_st_label (gfc_statement_label
);
978 gfc_statement_label
= NULL
;
985 /* Comments have already been skipped by the time we get here,
986 except for GCC attributes and OpenMP/OpenACC directives. */
988 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
989 c
= gfc_peek_ascii_char ();
995 c
= gfc_next_ascii_char ();
996 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
997 gcc_assert (c
== "gcc$"[i
]);
999 gfc_gobble_whitespace ();
1000 return decode_gcc_attribute ();
1005 /* Since both OpenMP and OpenACC directives starts with
1006 !$ character sequence, we must check all flags combinations */
1007 if ((flag_openmp
|| flag_openmp_simd
)
1010 verify_token_free ("$omp", 4, last_was_use_stmt
);
1011 return decode_omp_directive ();
1013 else if ((flag_openmp
|| flag_openmp_simd
)
1016 gfc_next_ascii_char (); /* Eat up dollar character */
1017 c
= gfc_peek_ascii_char ();
1021 verify_token_free ("omp", 3, last_was_use_stmt
);
1022 return decode_omp_directive ();
1026 verify_token_free ("acc", 3, last_was_use_stmt
);
1027 return decode_oacc_directive ();
1030 else if (flag_openacc
)
1032 verify_token_free ("$acc", 4, last_was_use_stmt
);
1033 return decode_oacc_directive ();
1039 if (at_bol
&& c
== ';')
1041 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1042 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1044 gfc_next_ascii_char (); /* Eat up the semicolon. */
1048 return decode_statement ();
1051 /* Assert next length characters to be equal to token in fixed form. */
1054 verify_token_fixed (const char *token
, int length
, bool last_was_use_stmt
)
1057 char c
= gfc_next_char_literal (NONSTRING
);
1059 for (i
= 0; i
< length
; i
++, c
= gfc_next_char_literal (NONSTRING
))
1060 gcc_assert ((char) gfc_wide_tolower (c
) == token
[i
]);
1062 if (c
!= ' ' && c
!= '0')
1064 gfc_buffer_error (false);
1065 gfc_error ("Bad continuation line at %C");
1068 if (last_was_use_stmt
)
1074 /* Get the next statement in fixed-form source. */
1076 static gfc_statement
1079 int label
, digit_flag
, i
;
1084 return decode_statement ();
1086 /* Skip past the current label field, parsing a statement label if
1087 one is there. This is a weird number parser, since the number is
1088 contained within five columns and can have any kind of embedded
1089 spaces. We also check for characters that make the rest of the
1095 for (i
= 0; i
< 5; i
++)
1097 c
= gfc_next_char_literal (NONSTRING
);
1114 label
= label
* 10 + ((unsigned char) c
- '0');
1115 label_locus
= gfc_current_locus
;
1119 /* Comments have already been skipped by the time we get
1120 here, except for GCC attributes and OpenMP directives. */
1123 c
= gfc_next_char_literal (NONSTRING
);
1125 if (TOLOWER (c
) == 'g')
1127 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
1128 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
1130 return decode_gcc_attribute ();
1134 if ((flag_openmp
|| flag_openmp_simd
)
1137 if (!verify_token_fixed ("omp", 3, last_was_use_stmt
))
1139 return decode_omp_directive ();
1141 else if ((flag_openmp
|| flag_openmp_simd
)
1144 c
= gfc_next_char_literal(NONSTRING
);
1145 if (c
== 'o' || c
== 'O')
1147 if (!verify_token_fixed ("mp", 2, last_was_use_stmt
))
1149 return decode_omp_directive ();
1151 else if (c
== 'a' || c
== 'A')
1153 if (!verify_token_fixed ("cc", 2, last_was_use_stmt
))
1155 return decode_oacc_directive ();
1158 else if (flag_openacc
)
1160 if (!verify_token_fixed ("acc", 3, last_was_use_stmt
))
1162 return decode_oacc_directive ();
1167 /* Comments have already been skipped by the time we get
1168 here so don't bother checking for them. */
1171 gfc_buffer_error (false);
1172 gfc_error ("Non-numeric character in statement label at %C");
1180 gfc_warning_now (0, "Zero is not a valid statement label at %C");
1183 /* We've found a valid statement label. */
1184 gfc_statement_label
= gfc_get_st_label (label
);
1188 /* Since this line starts a statement, it cannot be a continuation
1189 of a previous statement. If we see something here besides a
1190 space or zero, it must be a bad continuation line. */
1192 c
= gfc_next_char_literal (NONSTRING
);
1196 if (c
!= ' ' && c
!= '0')
1198 gfc_buffer_error (false);
1199 gfc_error ("Bad continuation line at %C");
1203 /* Now that we've taken care of the statement label columns, we have
1204 to make sure that the first nonblank character is not a '!'. If
1205 it is, the rest of the line is a comment. */
1209 loc
= gfc_current_locus
;
1210 c
= gfc_next_char_literal (NONSTRING
);
1212 while (gfc_is_whitespace (c
));
1216 gfc_current_locus
= loc
;
1221 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1222 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1223 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1228 if (gfc_match_eos () == MATCH_YES
)
1231 /* At this point, we've got a nonblank statement to parse. */
1232 return decode_statement ();
1236 gfc_warning_now (0, "Ignoring statement label in empty statement at %L",
1239 gfc_current_locus
.lb
->truncated
= 0;
1240 gfc_advance_line ();
1245 /* Return the next non-ST_NONE statement to the caller. We also worry
1246 about including files and the ends of include files at this stage. */
1248 static gfc_statement
1249 next_statement (void)
1254 gfc_enforce_clean_symbol_state ();
1256 gfc_new_block
= NULL
;
1258 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
1259 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1260 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
1263 gfc_statement_label
= NULL
;
1264 gfc_buffer_error (true);
1267 gfc_advance_line ();
1269 gfc_skip_comments ();
1277 if (gfc_define_undef_line ())
1280 old_locus
= gfc_current_locus
;
1282 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1288 gfc_buffer_error (false);
1290 if (st
== ST_GET_FCN_CHARACTERISTICS
&& gfc_statement_label
!= NULL
)
1292 gfc_free_st_label (gfc_statement_label
);
1293 gfc_statement_label
= NULL
;
1294 gfc_current_locus
= old_locus
;
1298 check_statement_label (st
);
1304 /****************************** Parser ***********************************/
1306 /* The parser subroutines are of type 'try' that fail if the file ends
1309 /* Macros that expand to case-labels for various classes of
1310 statements. Start with executable statements that directly do
1313 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1314 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1315 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1316 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1317 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1318 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1319 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1320 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1321 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1322 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
1323 case ST_OMP_TARGET_UPDATE: case ST_ERROR_STOP: case ST_SYNC_ALL: \
1324 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1325 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1326 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1328 /* Statements that mark other executable statements. */
1330 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1331 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1332 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1333 case ST_OMP_PARALLEL: \
1334 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1335 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
1336 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1337 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1338 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1339 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1340 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1341 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1342 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1343 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1344 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1345 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1346 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1347 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1348 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1349 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1350 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: \
1352 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1353 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: case ST_OACC_KERNELS_LOOP
1355 /* Declaration statements */
1357 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1358 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1359 case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
1360 case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD: case ST_OMP_DECLARE_REDUCTION: \
1361 case ST_OMP_DECLARE_TARGET: case ST_OACC_ROUTINE
1363 /* Block end statements. Errors associated with interchanging these
1364 are detected in gfc_match_end(). */
1366 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1367 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1368 case ST_END_BLOCK: case ST_END_ASSOCIATE
1371 /* Push a new state onto the stack. */
1374 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1376 p
->state
= new_state
;
1377 p
->previous
= gfc_state_stack
;
1379 p
->head
= p
->tail
= NULL
;
1380 p
->do_variable
= NULL
;
1381 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1382 p
->ext
.oacc_declare_clauses
= NULL
;
1384 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1385 construct statement was accepted right before pushing the state. Thus,
1386 the construct's gfc_code is available as tail of the parent state. */
1387 gcc_assert (gfc_state_stack
);
1388 p
->construct
= gfc_state_stack
->tail
;
1390 gfc_state_stack
= p
;
1394 /* Pop the current state. */
1398 gfc_state_stack
= gfc_state_stack
->previous
;
1402 /* Try to find the given state in the state stack. */
1405 gfc_find_state (gfc_compile_state state
)
1409 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1410 if (p
->state
== state
)
1413 return (p
== NULL
) ? false : true;
1417 /* Starts a new level in the statement list. */
1420 new_level (gfc_code
*q
)
1424 p
= q
->block
= gfc_get_code (EXEC_NOP
);
1426 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1432 /* Add the current new_st code structure and adds it to the current
1433 program unit. As a side-effect, it zeroes the new_st. */
1436 add_statement (void)
1440 p
= XCNEW (gfc_code
);
1443 p
->loc
= gfc_current_locus
;
1445 if (gfc_state_stack
->head
== NULL
)
1446 gfc_state_stack
->head
= p
;
1448 gfc_state_stack
->tail
->next
= p
;
1450 while (p
->next
!= NULL
)
1453 gfc_state_stack
->tail
= p
;
1455 gfc_clear_new_st ();
1461 /* Frees everything associated with the current statement. */
1464 undo_new_statement (void)
1466 gfc_free_statements (new_st
.block
);
1467 gfc_free_statements (new_st
.next
);
1468 gfc_free_statement (&new_st
);
1469 gfc_clear_new_st ();
1473 /* If the current statement has a statement label, make sure that it
1474 is allowed to, or should have one. */
1477 check_statement_label (gfc_statement st
)
1481 if (gfc_statement_label
== NULL
)
1483 if (st
== ST_FORMAT
)
1484 gfc_error ("FORMAT statement at %L does not have a statement label",
1491 case ST_END_PROGRAM
:
1492 case ST_END_FUNCTION
:
1493 case ST_END_SUBROUTINE
:
1497 case ST_END_CRITICAL
:
1499 case ST_END_ASSOCIATE
:
1502 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
1503 type
= ST_LABEL_DO_TARGET
;
1505 type
= ST_LABEL_TARGET
;
1509 type
= ST_LABEL_FORMAT
;
1512 /* Statement labels are not restricted from appearing on a
1513 particular line. However, there are plenty of situations
1514 where the resulting label can't be referenced. */
1517 type
= ST_LABEL_BAD_TARGET
;
1521 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1523 new_st
.here
= gfc_statement_label
;
1527 /* Figures out what the enclosing program unit is. This will be a
1528 function, subroutine, program, block data or module. */
1531 gfc_enclosing_unit (gfc_compile_state
* result
)
1535 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1536 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1537 || p
->state
== COMP_MODULE
|| p
->state
== COMP_BLOCK_DATA
1538 || p
->state
== COMP_PROGRAM
)
1547 *result
= COMP_PROGRAM
;
1552 /* Translate a statement enum to a string. */
1555 gfc_ascii_statement (gfc_statement st
)
1561 case ST_ARITHMETIC_IF
:
1562 p
= _("arithmetic IF");
1571 p
= _("attribute declaration");
1607 p
= _("data declaration");
1615 case ST_DERIVED_DECL
:
1616 p
= _("derived type declaration");
1630 case ST_END_ASSOCIATE
:
1631 p
= "END ASSOCIATE";
1636 case ST_END_BLOCK_DATA
:
1637 p
= "END BLOCK DATA";
1639 case ST_END_CRITICAL
:
1651 case ST_END_FUNCTION
:
1657 case ST_END_INTERFACE
:
1658 p
= "END INTERFACE";
1663 case ST_END_PROGRAM
:
1669 case ST_END_SUBROUTINE
:
1670 p
= "END SUBROUTINE";
1681 case ST_EQUIVALENCE
:
1693 case ST_FORALL_BLOCK
: /* Fall through */
1715 case ST_IMPLICIT_NONE
:
1716 p
= "IMPLICIT NONE";
1718 case ST_IMPLIED_ENDDO
:
1719 p
= _("implied END DO");
1748 case ST_MODULE_PROC
:
1749 p
= "MODULE PROCEDURE";
1781 case ST_SYNC_IMAGES
:
1784 case ST_SYNC_MEMORY
:
1799 case ST_WHERE_BLOCK
: /* Fall through */
1810 p
= _("assignment");
1812 case ST_POINTER_ASSIGNMENT
:
1813 p
= _("pointer assignment");
1815 case ST_SELECT_CASE
:
1818 case ST_SELECT_TYPE
:
1833 case ST_STATEMENT_FUNCTION
:
1834 p
= "STATEMENT FUNCTION";
1836 case ST_LABEL_ASSIGNMENT
:
1837 p
= "LABEL ASSIGNMENT";
1840 p
= "ENUM DEFINITION";
1843 p
= "ENUMERATOR DEFINITION";
1848 case ST_OACC_PARALLEL_LOOP
:
1849 p
= "!$ACC PARALLEL LOOP";
1851 case ST_OACC_END_PARALLEL_LOOP
:
1852 p
= "!$ACC END PARALLEL LOOP";
1854 case ST_OACC_PARALLEL
:
1855 p
= "!$ACC PARALLEL";
1857 case ST_OACC_END_PARALLEL
:
1858 p
= "!$ACC END PARALLEL";
1860 case ST_OACC_KERNELS
:
1861 p
= "!$ACC KERNELS";
1863 case ST_OACC_END_KERNELS
:
1864 p
= "!$ACC END KERNELS";
1866 case ST_OACC_KERNELS_LOOP
:
1867 p
= "!$ACC KERNELS LOOP";
1869 case ST_OACC_END_KERNELS_LOOP
:
1870 p
= "!$ACC END KERNELS LOOP";
1875 case ST_OACC_END_DATA
:
1876 p
= "!$ACC END DATA";
1878 case ST_OACC_HOST_DATA
:
1879 p
= "!$ACC HOST_DATA";
1881 case ST_OACC_END_HOST_DATA
:
1882 p
= "!$ACC END HOST_DATA";
1887 case ST_OACC_END_LOOP
:
1888 p
= "!$ACC END LOOP";
1890 case ST_OACC_DECLARE
:
1891 p
= "!$ACC DECLARE";
1893 case ST_OACC_UPDATE
:
1902 case ST_OACC_ENTER_DATA
:
1903 p
= "!$ACC ENTER DATA";
1905 case ST_OACC_EXIT_DATA
:
1906 p
= "!$ACC EXIT DATA";
1908 case ST_OACC_ROUTINE
:
1909 p
= "!$ACC ROUTINE";
1914 case ST_OMP_BARRIER
:
1915 p
= "!$OMP BARRIER";
1920 case ST_OMP_CANCELLATION_POINT
:
1921 p
= "!$OMP CANCELLATION POINT";
1923 case ST_OMP_CRITICAL
:
1924 p
= "!$OMP CRITICAL";
1926 case ST_OMP_DECLARE_REDUCTION
:
1927 p
= "!$OMP DECLARE REDUCTION";
1929 case ST_OMP_DECLARE_SIMD
:
1930 p
= "!$OMP DECLARE SIMD";
1932 case ST_OMP_DECLARE_TARGET
:
1933 p
= "!$OMP DECLARE TARGET";
1935 case ST_OMP_DISTRIBUTE
:
1936 p
= "!$OMP DISTRIBUTE";
1938 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
1939 p
= "!$OMP DISTRIBUTE PARALLEL DO";
1941 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
1942 p
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
1944 case ST_OMP_DISTRIBUTE_SIMD
:
1945 p
= "!$OMP DISTRIBUTE SIMD";
1950 case ST_OMP_DO_SIMD
:
1951 p
= "!$OMP DO SIMD";
1953 case ST_OMP_END_ATOMIC
:
1954 p
= "!$OMP END ATOMIC";
1956 case ST_OMP_END_CRITICAL
:
1957 p
= "!$OMP END CRITICAL";
1959 case ST_OMP_END_DISTRIBUTE
:
1960 p
= "!$OMP END DISTRIBUTE";
1962 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO
:
1963 p
= "!$OMP END DISTRIBUTE PARALLEL DO";
1965 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
:
1966 p
= "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
1968 case ST_OMP_END_DISTRIBUTE_SIMD
:
1969 p
= "!$OMP END DISTRIBUTE SIMD";
1974 case ST_OMP_END_DO_SIMD
:
1975 p
= "!$OMP END DO SIMD";
1977 case ST_OMP_END_SIMD
:
1978 p
= "!$OMP END SIMD";
1980 case ST_OMP_END_MASTER
:
1981 p
= "!$OMP END MASTER";
1983 case ST_OMP_END_ORDERED
:
1984 p
= "!$OMP END ORDERED";
1986 case ST_OMP_END_PARALLEL
:
1987 p
= "!$OMP END PARALLEL";
1989 case ST_OMP_END_PARALLEL_DO
:
1990 p
= "!$OMP END PARALLEL DO";
1992 case ST_OMP_END_PARALLEL_DO_SIMD
:
1993 p
= "!$OMP END PARALLEL DO SIMD";
1995 case ST_OMP_END_PARALLEL_SECTIONS
:
1996 p
= "!$OMP END PARALLEL SECTIONS";
1998 case ST_OMP_END_PARALLEL_WORKSHARE
:
1999 p
= "!$OMP END PARALLEL WORKSHARE";
2001 case ST_OMP_END_SECTIONS
:
2002 p
= "!$OMP END SECTIONS";
2004 case ST_OMP_END_SINGLE
:
2005 p
= "!$OMP END SINGLE";
2007 case ST_OMP_END_TASK
:
2008 p
= "!$OMP END TASK";
2010 case ST_OMP_END_TARGET
:
2011 p
= "!$OMP END TARGET";
2013 case ST_OMP_END_TARGET_DATA
:
2014 p
= "!$OMP END TARGET DATA";
2016 case ST_OMP_END_TARGET_TEAMS
:
2017 p
= "!$OMP END TARGET TEAMS";
2019 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
:
2020 p
= "!$OMP END TARGET TEAMS DISTRIBUTE";
2022 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2023 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2025 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2026 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2028 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2029 p
= "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2031 case ST_OMP_END_TASKGROUP
:
2032 p
= "!$OMP END TASKGROUP";
2034 case ST_OMP_END_TEAMS
:
2035 p
= "!$OMP END TEAMS";
2037 case ST_OMP_END_TEAMS_DISTRIBUTE
:
2038 p
= "!$OMP END TEAMS DISTRIBUTE";
2040 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2041 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2043 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2044 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2046 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
:
2047 p
= "!$OMP END TEAMS DISTRIBUTE SIMD";
2049 case ST_OMP_END_WORKSHARE
:
2050 p
= "!$OMP END WORKSHARE";
2058 case ST_OMP_ORDERED
:
2059 p
= "!$OMP ORDERED";
2061 case ST_OMP_PARALLEL
:
2062 p
= "!$OMP PARALLEL";
2064 case ST_OMP_PARALLEL_DO
:
2065 p
= "!$OMP PARALLEL DO";
2067 case ST_OMP_PARALLEL_DO_SIMD
:
2068 p
= "!$OMP PARALLEL DO SIMD";
2070 case ST_OMP_PARALLEL_SECTIONS
:
2071 p
= "!$OMP PARALLEL SECTIONS";
2073 case ST_OMP_PARALLEL_WORKSHARE
:
2074 p
= "!$OMP PARALLEL WORKSHARE";
2076 case ST_OMP_SECTIONS
:
2077 p
= "!$OMP SECTIONS";
2079 case ST_OMP_SECTION
:
2080 p
= "!$OMP SECTION";
2091 case ST_OMP_TARGET_DATA
:
2092 p
= "!$OMP TARGET DATA";
2094 case ST_OMP_TARGET_TEAMS
:
2095 p
= "!$OMP TARGET TEAMS";
2097 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
2098 p
= "!$OMP TARGET TEAMS DISTRIBUTE";
2100 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2101 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2103 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2104 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2106 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2107 p
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2109 case ST_OMP_TARGET_UPDATE
:
2110 p
= "!$OMP TARGET UPDATE";
2115 case ST_OMP_TASKGROUP
:
2116 p
= "!$OMP TASKGROUP";
2118 case ST_OMP_TASKWAIT
:
2119 p
= "!$OMP TASKWAIT";
2121 case ST_OMP_TASKYIELD
:
2122 p
= "!$OMP TASKYIELD";
2127 case ST_OMP_TEAMS_DISTRIBUTE
:
2128 p
= "!$OMP TEAMS DISTRIBUTE";
2130 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2131 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2133 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2134 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2136 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
2137 p
= "!$OMP TEAMS DISTRIBUTE SIMD";
2139 case ST_OMP_THREADPRIVATE
:
2140 p
= "!$OMP THREADPRIVATE";
2142 case ST_OMP_WORKSHARE
:
2143 p
= "!$OMP WORKSHARE";
2146 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2153 /* Create a symbol for the main program and assign it to ns->proc_name. */
2156 main_program_symbol (gfc_namespace
*ns
, const char *name
)
2158 gfc_symbol
*main_program
;
2159 symbol_attribute attr
;
2161 gfc_get_symbol (name
, ns
, &main_program
);
2162 gfc_clear_attr (&attr
);
2163 attr
.flavor
= FL_PROGRAM
;
2164 attr
.proc
= PROC_UNKNOWN
;
2165 attr
.subroutine
= 1;
2166 attr
.access
= ACCESS_PUBLIC
;
2167 attr
.is_main_program
= 1;
2168 main_program
->attr
= attr
;
2169 main_program
->declared_at
= gfc_current_locus
;
2170 ns
->proc_name
= main_program
;
2171 gfc_commit_symbols ();
2175 /* Do whatever is necessary to accept the last statement. */
2178 accept_statement (gfc_statement st
)
2182 case ST_IMPLICIT_NONE
:
2189 gfc_current_ns
->proc_name
= gfc_new_block
;
2192 /* If the statement is the end of a block, lay down a special code
2193 that allows a branch to the end of the block from within the
2194 construct. IF and SELECT are treated differently from DO
2195 (where EXEC_NOP is added inside the loop) for two
2197 1. END DO has a meaning in the sense that after a GOTO to
2198 it, the loop counter must be increased.
2199 2. IF blocks and SELECT blocks can consist of multiple
2200 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
2201 Putting the label before the END IF would make the jump
2202 from, say, the ELSE IF block to the END IF illegal. */
2206 case ST_END_CRITICAL
:
2207 if (gfc_statement_label
!= NULL
)
2209 new_st
.op
= EXEC_END_NESTED_BLOCK
;
2214 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
2215 one parallel block. Thus, we add the special code to the nested block
2216 itself, instead of the parent one. */
2218 case ST_END_ASSOCIATE
:
2219 if (gfc_statement_label
!= NULL
)
2221 new_st
.op
= EXEC_END_BLOCK
;
2226 /* The end-of-program unit statements do not get the special
2227 marker and require a statement of some sort if they are a
2230 case ST_END_PROGRAM
:
2231 case ST_END_FUNCTION
:
2232 case ST_END_SUBROUTINE
:
2233 if (gfc_statement_label
!= NULL
)
2235 new_st
.op
= EXEC_RETURN
;
2240 new_st
.op
= EXEC_END_PROCEDURE
;
2256 gfc_commit_symbols ();
2257 gfc_warning_check ();
2258 gfc_clear_new_st ();
2262 /* Undo anything tentative that has been built for the current
2266 reject_statement (void)
2268 /* Revert to the previous charlen chain. */
2269 gfc_free_charlen (gfc_current_ns
->cl_list
, gfc_current_ns
->old_cl_list
);
2270 gfc_current_ns
->cl_list
= gfc_current_ns
->old_cl_list
;
2272 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
2273 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
2275 gfc_reject_data (gfc_current_ns
);
2277 gfc_new_block
= NULL
;
2278 gfc_undo_symbols ();
2279 gfc_clear_warning ();
2280 undo_new_statement ();
2284 /* Generic complaint about an out of order statement. We also do
2285 whatever is necessary to clean up. */
2288 unexpected_statement (gfc_statement st
)
2290 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
2292 reject_statement ();
2296 /* Given the next statement seen by the matcher, make sure that it is
2297 in proper order with the last. This subroutine is initialized by
2298 calling it with an argument of ST_NONE. If there is a problem, we
2299 issue an error and return false. Otherwise we return true.
2301 Individual parsers need to verify that the statements seen are
2302 valid before calling here, i.e., ENTRY statements are not allowed in
2303 INTERFACE blocks. The following diagram is taken from the standard:
2305 +---------------------------------------+
2306 | program subroutine function module |
2307 +---------------------------------------+
2309 +---------------------------------------+
2311 +---------------------------------------+
2313 | +-----------+------------------+
2314 | | parameter | implicit |
2315 | +-----------+------------------+
2316 | format | | derived type |
2317 | entry | parameter | interface |
2318 | | data | specification |
2319 | | | statement func |
2320 | +-----------+------------------+
2321 | | data | executable |
2322 +--------+-----------+------------------+
2324 +---------------------------------------+
2325 | internal module/subprogram |
2326 +---------------------------------------+
2328 +---------------------------------------+
2337 ORDER_IMPLICIT_NONE
,
2345 enum state_order state
;
2346 gfc_statement last_statement
;
2352 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
2358 p
->state
= ORDER_START
;
2362 if (p
->state
> ORDER_USE
)
2364 p
->state
= ORDER_USE
;
2368 if (p
->state
> ORDER_IMPORT
)
2370 p
->state
= ORDER_IMPORT
;
2373 case ST_IMPLICIT_NONE
:
2374 if (p
->state
> ORDER_IMPLICIT
)
2377 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2378 statement disqualifies a USE but not an IMPLICIT NONE.
2379 Duplicate IMPLICIT NONEs are caught when the implicit types
2382 p
->state
= ORDER_IMPLICIT_NONE
;
2386 if (p
->state
> ORDER_IMPLICIT
)
2388 p
->state
= ORDER_IMPLICIT
;
2393 if (p
->state
< ORDER_IMPLICIT_NONE
)
2394 p
->state
= ORDER_IMPLICIT_NONE
;
2398 if (p
->state
>= ORDER_EXEC
)
2400 if (p
->state
< ORDER_IMPLICIT
)
2401 p
->state
= ORDER_IMPLICIT
;
2405 if (p
->state
< ORDER_SPEC
)
2406 p
->state
= ORDER_SPEC
;
2411 case ST_DERIVED_DECL
:
2412 case ST_OACC_DECLARE
:
2414 if (p
->state
>= ORDER_EXEC
)
2416 if (p
->state
< ORDER_SPEC
)
2417 p
->state
= ORDER_SPEC
;
2422 if (p
->state
< ORDER_EXEC
)
2423 p
->state
= ORDER_EXEC
;
2430 /* All is well, record the statement in case we need it next time. */
2431 p
->where
= gfc_current_locus
;
2432 p
->last_statement
= st
;
2437 gfc_error ("%s statement at %C cannot follow %s statement at %L",
2438 gfc_ascii_statement (st
),
2439 gfc_ascii_statement (p
->last_statement
), &p
->where
);
2445 /* Handle an unexpected end of file. This is a show-stopper... */
2447 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
2450 unexpected_eof (void)
2454 gfc_error ("Unexpected end of file in %qs", gfc_source_file
);
2456 /* Memory cleanup. Move to "second to last". */
2457 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
2460 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
2463 longjmp (eof_buf
, 1);
2467 /* Parse the CONTAINS section of a derived type definition. */
2469 gfc_access gfc_typebound_default_access
;
2472 parse_derived_contains (void)
2475 bool seen_private
= false;
2476 bool seen_comps
= false;
2477 bool error_flag
= false;
2480 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2481 gcc_assert (gfc_current_block ());
2483 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
2485 if (gfc_current_block ()->attr
.sequence
)
2486 gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
2487 " section at %C", gfc_current_block ()->name
);
2488 if (gfc_current_block ()->attr
.is_bind_c
)
2489 gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
2490 " section at %C", gfc_current_block ()->name
);
2492 accept_statement (ST_CONTAINS
);
2493 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
2495 gfc_typebound_default_access
= ACCESS_PUBLIC
;
2501 st
= next_statement ();
2509 gfc_error ("Components in TYPE at %C must precede CONTAINS");
2513 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
2516 accept_statement (ST_PROCEDURE
);
2521 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
2524 accept_statement (ST_GENERIC
);
2529 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
2533 accept_statement (ST_FINAL
);
2541 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
2542 "at %C with empty CONTAINS section")))
2545 /* ST_END_TYPE is accepted by parse_derived after return. */
2549 if (!gfc_find_state (COMP_MODULE
))
2551 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2558 gfc_error ("PRIVATE statement at %C must precede procedure"
2565 gfc_error ("Duplicate PRIVATE statement at %C");
2569 accept_statement (ST_PRIVATE
);
2570 gfc_typebound_default_access
= ACCESS_PRIVATE
;
2571 seen_private
= true;
2575 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2579 gfc_error ("Already inside a CONTAINS block at %C");
2583 unexpected_statement (st
);
2591 reject_statement ();
2595 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2601 /* Parse a derived type. */
2604 parse_derived (void)
2606 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
2610 gfc_component
*c
, *lock_comp
= NULL
;
2612 accept_statement (ST_DERIVED_DECL
);
2613 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
2615 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
2622 while (compiling_type
)
2624 st
= next_statement ();
2632 accept_statement (st
);
2637 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
2644 if (!seen_component
)
2645 gfc_notify_std (GFC_STD_F2003
, "Derived type "
2646 "definition at %C without components");
2648 accept_statement (ST_END_TYPE
);
2652 if (!gfc_find_state (COMP_MODULE
))
2654 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2661 gfc_error ("PRIVATE statement at %C must precede "
2662 "structure components");
2667 gfc_error ("Duplicate PRIVATE statement at %C");
2669 s
.sym
->component_access
= ACCESS_PRIVATE
;
2671 accept_statement (ST_PRIVATE
);
2678 gfc_error ("SEQUENCE statement at %C must precede "
2679 "structure components");
2683 if (gfc_current_block ()->attr
.sequence
)
2684 gfc_warning (0, "SEQUENCE attribute at %C already specified in "
2689 gfc_error ("Duplicate SEQUENCE statement at %C");
2693 gfc_add_sequence (&gfc_current_block ()->attr
,
2694 gfc_current_block ()->name
, NULL
);
2698 gfc_notify_std (GFC_STD_F2003
,
2699 "CONTAINS block in derived type"
2700 " definition at %C");
2702 accept_statement (ST_CONTAINS
);
2703 parse_derived_contains ();
2707 unexpected_statement (st
);
2712 /* need to verify that all fields of the derived type are
2713 * interoperable with C if the type is declared to be bind(c)
2715 sym
= gfc_current_block ();
2716 for (c
= sym
->components
; c
; c
= c
->next
)
2718 bool coarray
, lock_type
, allocatable
, pointer
;
2719 coarray
= lock_type
= allocatable
= pointer
= false;
2721 /* Look for allocatable components. */
2722 if (c
->attr
.allocatable
2723 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2724 && CLASS_DATA (c
)->attr
.allocatable
)
2725 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
2726 && c
->ts
.u
.derived
->attr
.alloc_comp
))
2729 sym
->attr
.alloc_comp
= 1;
2732 /* Look for pointer components. */
2734 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2735 && CLASS_DATA (c
)->attr
.class_pointer
)
2736 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
2739 sym
->attr
.pointer_comp
= 1;
2742 /* Look for procedure pointer components. */
2743 if (c
->attr
.proc_pointer
2744 || (c
->ts
.type
== BT_DERIVED
2745 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
2746 sym
->attr
.proc_pointer_comp
= 1;
2748 /* Looking for coarray components. */
2749 if (c
->attr
.codimension
2750 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2751 && CLASS_DATA (c
)->attr
.codimension
))
2754 sym
->attr
.coarray_comp
= 1;
2757 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
2758 && !c
->attr
.pointer
)
2761 sym
->attr
.coarray_comp
= 1;
2764 /* Looking for lock_type components. */
2765 if ((c
->ts
.type
== BT_DERIVED
2766 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2767 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2768 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2769 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2770 == INTMOD_ISO_FORTRAN_ENV
2771 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2772 == ISOFORTRAN_LOCK_TYPE
)
2773 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
2774 && !allocatable
&& !pointer
))
2778 sym
->attr
.lock_comp
= 1;
2781 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2782 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2783 unless there are nondirect [allocatable or pointer] components
2784 involved (cf. 1.3.33.1 and 1.3.33.3). */
2786 if (pointer
&& !coarray
&& lock_type
)
2787 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2788 "codimension or be a subcomponent of a coarray, "
2789 "which is not possible as the component has the "
2790 "pointer attribute", c
->name
, &c
->loc
);
2791 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
2792 && c
->ts
.u
.derived
->attr
.lock_comp
)
2793 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2794 "of type LOCK_TYPE, which must have a codimension or be a "
2795 "subcomponent of a coarray", c
->name
, &c
->loc
);
2797 if (lock_type
&& allocatable
&& !coarray
)
2798 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
2799 "a codimension", c
->name
, &c
->loc
);
2800 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
2801 && c
->ts
.u
.derived
->attr
.lock_comp
)
2802 gfc_error ("Allocatable component %s at %L must have a codimension as "
2803 "it has a noncoarray subcomponent of type LOCK_TYPE",
2806 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
2807 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2808 "subcomponent of type LOCK_TYPE must have a codimension or "
2809 "be a subcomponent of a coarray. (Variables of type %s may "
2810 "not have a codimension as already a coarray "
2811 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
2813 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
2814 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2815 "subcomponent of type LOCK_TYPE must have a codimension or "
2816 "be a subcomponent of a coarray. (Variables of type %s may "
2817 "not have a codimension as %s at %L has a codimension or a "
2818 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
2819 sym
->name
, c
->name
, &c
->loc
);
2821 /* Look for private components. */
2822 if (sym
->component_access
== ACCESS_PRIVATE
2823 || c
->attr
.access
== ACCESS_PRIVATE
2824 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
2825 sym
->attr
.private_comp
= 1;
2828 if (!seen_component
)
2829 sym
->attr
.zero_comp
= 1;
2835 /* Parse an ENUM. */
2843 int seen_enumerator
= 0;
2845 push_state (&s
, COMP_ENUM
, gfc_new_block
);
2849 while (compiling_enum
)
2851 st
= next_statement ();
2859 seen_enumerator
= 1;
2860 accept_statement (st
);
2865 if (!seen_enumerator
)
2866 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2867 accept_statement (st
);
2871 gfc_free_enum_history ();
2872 unexpected_statement (st
);
2880 /* Parse an interface. We must be able to deal with the possibility
2881 of recursive interfaces. The parse_spec() subroutine is mutually
2882 recursive with parse_interface(). */
2884 static gfc_statement
parse_spec (gfc_statement
);
2887 parse_interface (void)
2889 gfc_compile_state new_state
= COMP_NONE
, current_state
;
2890 gfc_symbol
*prog_unit
, *sym
;
2891 gfc_interface_info save
;
2892 gfc_state_data s1
, s2
;
2895 accept_statement (ST_INTERFACE
);
2897 current_interface
.ns
= gfc_current_ns
;
2898 save
= current_interface
;
2900 sym
= (current_interface
.type
== INTERFACE_GENERIC
2901 || current_interface
.type
== INTERFACE_USER_OP
)
2902 ? gfc_new_block
: NULL
;
2904 push_state (&s1
, COMP_INTERFACE
, sym
);
2905 current_state
= COMP_NONE
;
2908 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
2910 st
= next_statement ();
2918 if (st
== ST_SUBROUTINE
)
2919 new_state
= COMP_SUBROUTINE
;
2920 else if (st
== ST_FUNCTION
)
2921 new_state
= COMP_FUNCTION
;
2922 if (gfc_new_block
->attr
.pointer
)
2924 gfc_new_block
->attr
.pointer
= 0;
2925 gfc_new_block
->attr
.proc_pointer
= 1;
2927 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
2928 gfc_new_block
->formal
, NULL
))
2930 reject_statement ();
2931 gfc_free_namespace (gfc_current_ns
);
2937 case ST_MODULE_PROC
: /* The module procedure matcher makes
2938 sure the context is correct. */
2939 accept_statement (st
);
2940 gfc_free_namespace (gfc_current_ns
);
2943 case ST_END_INTERFACE
:
2944 gfc_free_namespace (gfc_current_ns
);
2945 gfc_current_ns
= current_interface
.ns
;
2949 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2950 gfc_ascii_statement (st
));
2951 reject_statement ();
2952 gfc_free_namespace (gfc_current_ns
);
2957 /* Make sure that the generic name has the right attribute. */
2958 if (current_interface
.type
== INTERFACE_GENERIC
2959 && current_state
== COMP_NONE
)
2961 if (new_state
== COMP_FUNCTION
&& sym
)
2962 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
2963 else if (new_state
== COMP_SUBROUTINE
&& sym
)
2964 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
2966 current_state
= new_state
;
2969 if (current_interface
.type
== INTERFACE_ABSTRACT
)
2971 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
2972 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
2973 gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
2974 "cannot be the same as an intrinsic type",
2975 gfc_new_block
->name
);
2978 push_state (&s2
, new_state
, gfc_new_block
);
2979 accept_statement (st
);
2980 prog_unit
= gfc_new_block
;
2981 prog_unit
->formal_ns
= gfc_current_ns
;
2982 if (prog_unit
== prog_unit
->formal_ns
->proc_name
2983 && prog_unit
->ns
!= prog_unit
->formal_ns
)
2987 /* Read data declaration statements. */
2988 st
= parse_spec (ST_NONE
);
2990 /* Since the interface block does not permit an IMPLICIT statement,
2991 the default type for the function or the result must be taken
2992 from the formal namespace. */
2993 if (new_state
== COMP_FUNCTION
)
2995 if (prog_unit
->result
== prog_unit
2996 && prog_unit
->ts
.type
== BT_UNKNOWN
)
2997 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
2998 else if (prog_unit
->result
!= prog_unit
2999 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
3000 gfc_set_default_type (prog_unit
->result
, 1,
3001 prog_unit
->formal_ns
);
3004 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
3006 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
3007 gfc_ascii_statement (st
));
3008 reject_statement ();
3012 /* Add EXTERNAL attribute to function or subroutine. */
3013 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
3014 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
3016 current_interface
= save
;
3017 gfc_add_interface (prog_unit
);
3020 if (current_interface
.ns
3021 && current_interface
.ns
->proc_name
3022 && strcmp (current_interface
.ns
->proc_name
->name
,
3023 prog_unit
->name
) == 0)
3024 gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
3025 "enclosing procedure", prog_unit
->name
,
3026 ¤t_interface
.ns
->proc_name
->declared_at
);
3035 /* Associate function characteristics by going back to the function
3036 declaration and rematching the prefix. */
3039 match_deferred_characteristics (gfc_typespec
* ts
)
3042 match m
= MATCH_ERROR
;
3043 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3045 loc
= gfc_current_locus
;
3047 gfc_current_locus
= gfc_current_block ()->declared_at
;
3050 gfc_buffer_error (true);
3051 m
= gfc_match_prefix (ts
);
3052 gfc_buffer_error (false);
3054 if (ts
->type
== BT_DERIVED
)
3062 /* Only permit one go at the characteristic association. */
3066 /* Set the function locus correctly. If we have not found the
3067 function name, there is an error. */
3069 && gfc_match ("function% %n", name
) == MATCH_YES
3070 && strcmp (name
, gfc_current_block ()->name
) == 0)
3072 gfc_current_block ()->declared_at
= gfc_current_locus
;
3073 gfc_commit_symbols ();
3078 gfc_undo_symbols ();
3081 gfc_current_locus
=loc
;
3086 /* Check specification-expressions in the function result of the currently
3087 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
3088 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
3089 scope are not yet parsed so this has to be delayed up to parse_spec. */
3092 check_function_result_typed (void)
3094 gfc_typespec
* ts
= &gfc_current_ns
->proc_name
->result
->ts
;
3096 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
3097 gcc_assert (ts
->type
!= BT_UNKNOWN
);
3099 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
3100 /* TODO: Extend when KIND type parameters are implemented. */
3101 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
)
3102 gfc_expr_check_typed (ts
->u
.cl
->length
, gfc_current_ns
, true);
3106 /* Parse a set of specification statements. Returns the statement
3107 that doesn't fit. */
3109 static gfc_statement
3110 parse_spec (gfc_statement st
)
3113 bool function_result_typed
= false;
3114 bool bad_characteristic
= false;
3117 verify_st_order (&ss
, ST_NONE
, false);
3119 st
= next_statement ();
3121 /* If we are not inside a function or don't have a result specified so far,
3122 do nothing special about it. */
3123 if (gfc_current_state () != COMP_FUNCTION
)
3124 function_result_typed
= true;
3127 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
3130 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
3131 function_result_typed
= true;
3136 /* If we're inside a BLOCK construct, some statements are disallowed.
3137 Check this here. Attribute declaration statements like INTENT, OPTIONAL
3138 or VALUE are also disallowed, but they don't have a particular ST_*
3139 key so we have to check for them individually in their matcher routine. */
3140 if (gfc_current_state () == COMP_BLOCK
)
3144 case ST_IMPLICIT_NONE
:
3147 case ST_EQUIVALENCE
:
3148 case ST_STATEMENT_FUNCTION
:
3149 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
3150 gfc_ascii_statement (st
));
3151 reject_statement ();
3157 else if (gfc_current_state () == COMP_BLOCK_DATA
)
3158 /* Fortran 2008, C1116. */
3165 case ST_END_BLOCK_DATA
:
3167 case ST_EQUIVALENCE
:
3170 case ST_IMPLICIT_NONE
:
3171 case ST_DERIVED_DECL
:
3179 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
3180 gfc_ascii_statement (st
));
3181 reject_statement ();
3185 /* If we find a statement that can not be followed by an IMPLICIT statement
3186 (and thus we can expect to see none any further), type the function result
3187 if it has not yet been typed. Be careful not to give the END statement
3188 to verify_st_order! */
3189 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
3191 bool verify_now
= false;
3193 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
3198 verify_st_order (&dummyss
, ST_NONE
, false);
3199 verify_st_order (&dummyss
, st
, false);
3201 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
3207 check_function_result_typed ();
3208 function_result_typed
= true;
3217 case ST_IMPLICIT_NONE
:
3219 if (!function_result_typed
)
3221 check_function_result_typed ();
3222 function_result_typed
= true;
3228 case ST_DATA
: /* Not allowed in interfaces */
3229 if (gfc_current_state () == COMP_INTERFACE
)
3239 case ST_DERIVED_DECL
:
3242 if (!verify_st_order (&ss
, st
, false))
3244 reject_statement ();
3245 st
= next_statement ();
3255 case ST_DERIVED_DECL
:
3261 if (gfc_current_state () != COMP_MODULE
)
3263 gfc_error ("%s statement must appear in a MODULE",
3264 gfc_ascii_statement (st
));
3265 reject_statement ();
3269 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
3271 gfc_error ("%s statement at %C follows another accessibility "
3272 "specification", gfc_ascii_statement (st
));
3273 reject_statement ();
3277 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
3278 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3282 case ST_STATEMENT_FUNCTION
:
3283 if (gfc_current_state () == COMP_MODULE
)
3285 unexpected_statement (st
);
3293 accept_statement (st
);
3294 st
= next_statement ();
3298 accept_statement (st
);
3300 st
= next_statement ();
3303 case ST_GET_FCN_CHARACTERISTICS
:
3304 /* This statement triggers the association of a function's result
3306 ts
= &gfc_current_block ()->result
->ts
;
3307 if (match_deferred_characteristics (ts
) != MATCH_YES
)
3308 bad_characteristic
= true;
3310 st
= next_statement ();
3313 case ST_OACC_DECLARE
:
3314 if (!verify_st_order(&ss
, st
, false))
3316 reject_statement ();
3317 st
= next_statement ();
3320 if (gfc_state_stack
->ext
.oacc_declare_clauses
== NULL
)
3321 gfc_state_stack
->ext
.oacc_declare_clauses
= new_st
.ext
.omp_clauses
;
3322 accept_statement (st
);
3323 st
= next_statement ();
3330 /* If match_deferred_characteristics failed, then there is an error. */
3331 if (bad_characteristic
)
3333 ts
= &gfc_current_block ()->result
->ts
;
3334 if (ts
->type
!= BT_DERIVED
)
3335 gfc_error ("Bad kind expression for function %qs at %L",
3336 gfc_current_block ()->name
,
3337 &gfc_current_block ()->declared_at
);
3339 gfc_error ("The type for function %qs at %L is not accessible",
3340 gfc_current_block ()->name
,
3341 &gfc_current_block ()->declared_at
);
3343 gfc_current_block ()->ts
.kind
= 0;
3344 /* Keep the derived type; if it's bad, it will be discovered later. */
3345 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
3346 ts
->type
= BT_UNKNOWN
;
3353 /* Parse a WHERE block, (not a simple WHERE statement). */
3356 parse_where_block (void)
3358 int seen_empty_else
;
3363 accept_statement (ST_WHERE_BLOCK
);
3364 top
= gfc_state_stack
->tail
;
3366 push_state (&s
, COMP_WHERE
, gfc_new_block
);
3368 d
= add_statement ();
3369 d
->expr1
= top
->expr1
;
3375 seen_empty_else
= 0;
3379 st
= next_statement ();
3385 case ST_WHERE_BLOCK
:
3386 parse_where_block ();
3391 accept_statement (st
);
3395 if (seen_empty_else
)
3397 gfc_error ("ELSEWHERE statement at %C follows previous "
3398 "unmasked ELSEWHERE");
3399 reject_statement ();
3403 if (new_st
.expr1
== NULL
)
3404 seen_empty_else
= 1;
3406 d
= new_level (gfc_state_stack
->head
);
3408 d
->expr1
= new_st
.expr1
;
3410 accept_statement (st
);
3415 accept_statement (st
);
3419 gfc_error ("Unexpected %s statement in WHERE block at %C",
3420 gfc_ascii_statement (st
));
3421 reject_statement ();
3425 while (st
!= ST_END_WHERE
);
3431 /* Parse a FORALL block (not a simple FORALL statement). */
3434 parse_forall_block (void)
3440 accept_statement (ST_FORALL_BLOCK
);
3441 top
= gfc_state_stack
->tail
;
3443 push_state (&s
, COMP_FORALL
, gfc_new_block
);
3445 d
= add_statement ();
3446 d
->op
= EXEC_FORALL
;
3451 st
= next_statement ();
3456 case ST_POINTER_ASSIGNMENT
:
3459 accept_statement (st
);
3462 case ST_WHERE_BLOCK
:
3463 parse_where_block ();
3466 case ST_FORALL_BLOCK
:
3467 parse_forall_block ();
3471 accept_statement (st
);
3478 gfc_error ("Unexpected %s statement in FORALL block at %C",
3479 gfc_ascii_statement (st
));
3481 reject_statement ();
3485 while (st
!= ST_END_FORALL
);
3491 static gfc_statement
parse_executable (gfc_statement
);
3493 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
3496 parse_if_block (void)
3505 accept_statement (ST_IF_BLOCK
);
3507 top
= gfc_state_stack
->tail
;
3508 push_state (&s
, COMP_IF
, gfc_new_block
);
3510 new_st
.op
= EXEC_IF
;
3511 d
= add_statement ();
3513 d
->expr1
= top
->expr1
;
3519 st
= parse_executable (ST_NONE
);
3529 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
3530 "statement at %L", &else_locus
);
3532 reject_statement ();
3536 d
= new_level (gfc_state_stack
->head
);
3538 d
->expr1
= new_st
.expr1
;
3540 accept_statement (st
);
3547 gfc_error ("Duplicate ELSE statements at %L and %C",
3549 reject_statement ();
3554 else_locus
= gfc_current_locus
;
3556 d
= new_level (gfc_state_stack
->head
);
3559 accept_statement (st
);
3567 unexpected_statement (st
);
3571 while (st
!= ST_ENDIF
);
3574 accept_statement (st
);
3578 /* Parse a SELECT block. */
3581 parse_select_block (void)
3587 accept_statement (ST_SELECT_CASE
);
3589 cp
= gfc_state_stack
->tail
;
3590 push_state (&s
, COMP_SELECT
, gfc_new_block
);
3592 /* Make sure that the next statement is a CASE or END SELECT. */
3595 st
= next_statement ();
3598 if (st
== ST_END_SELECT
)
3600 /* Empty SELECT CASE is OK. */
3601 accept_statement (st
);
3608 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
3611 reject_statement ();
3614 /* At this point, we're got a nonempty select block. */
3615 cp
= new_level (cp
);
3618 accept_statement (st
);
3622 st
= parse_executable (ST_NONE
);
3629 cp
= new_level (gfc_state_stack
->head
);
3631 gfc_clear_new_st ();
3633 accept_statement (st
);
3639 /* Can't have an executable statement because of
3640 parse_executable(). */
3642 unexpected_statement (st
);
3646 while (st
!= ST_END_SELECT
);
3649 accept_statement (st
);
3653 /* Pop the current selector from the SELECT TYPE stack. */
3656 select_type_pop (void)
3658 gfc_select_type_stack
*old
= select_type_stack
;
3659 select_type_stack
= old
->prev
;
3664 /* Parse a SELECT TYPE construct (F03:R821). */
3667 parse_select_type_block (void)
3673 accept_statement (ST_SELECT_TYPE
);
3675 cp
= gfc_state_stack
->tail
;
3676 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
3678 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
3682 st
= next_statement ();
3685 if (st
== ST_END_SELECT
)
3686 /* Empty SELECT CASE is OK. */
3688 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
3691 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
3692 "following SELECT TYPE at %C");
3694 reject_statement ();
3697 /* At this point, we're got a nonempty select block. */
3698 cp
= new_level (cp
);
3701 accept_statement (st
);
3705 st
= parse_executable (ST_NONE
);
3713 cp
= new_level (gfc_state_stack
->head
);
3715 gfc_clear_new_st ();
3717 accept_statement (st
);
3723 /* Can't have an executable statement because of
3724 parse_executable(). */
3726 unexpected_statement (st
);
3730 while (st
!= ST_END_SELECT
);
3734 accept_statement (st
);
3735 gfc_current_ns
= gfc_current_ns
->parent
;
3740 /* Given a symbol, make sure it is not an iteration variable for a DO
3741 statement. This subroutine is called when the symbol is seen in a
3742 context that causes it to become redefined. If the symbol is an
3743 iterator, we generate an error message and return nonzero. */
3746 gfc_check_do_variable (gfc_symtree
*st
)
3750 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
3751 if (s
->do_variable
== st
)
3753 gfc_error_now ("Variable %qs at %C cannot be redefined inside "
3754 "loop beginning at %L", st
->name
, &s
->head
->loc
);
3762 /* Checks to see if the current statement label closes an enddo.
3763 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3764 an error) if it incorrectly closes an ENDDO. */
3767 check_do_closure (void)
3771 if (gfc_statement_label
== NULL
)
3774 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
3775 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
3779 return 0; /* No loops to close */
3781 if (p
->ext
.end_do_label
== gfc_statement_label
)
3783 if (p
== gfc_state_stack
)
3786 gfc_error ("End of nonblock DO statement at %C is within another block");
3790 /* At this point, the label doesn't terminate the innermost loop.
3791 Make sure it doesn't terminate another one. */
3792 for (; p
; p
= p
->previous
)
3793 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
3794 && p
->ext
.end_do_label
== gfc_statement_label
)
3796 gfc_error ("End of nonblock DO statement at %C is interwoven "
3797 "with another DO loop");
3805 /* Parse a series of contained program units. */
3807 static void parse_progunit (gfc_statement
);
3810 /* Parse a CRITICAL block. */
3813 parse_critical_block (void)
3816 gfc_state_data s
, *sd
;
3819 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
3820 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
3821 gfc_error_now (is_oacc (sd
)
3822 ? "CRITICAL block inside of OpenACC region at %C"
3823 : "CRITICAL block inside of OpenMP region at %C");
3825 s
.ext
.end_do_label
= new_st
.label1
;
3827 accept_statement (ST_CRITICAL
);
3828 top
= gfc_state_stack
->tail
;
3830 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
3832 d
= add_statement ();
3833 d
->op
= EXEC_CRITICAL
;
3838 st
= parse_executable (ST_NONE
);
3846 case ST_END_CRITICAL
:
3847 if (s
.ext
.end_do_label
!= NULL
3848 && s
.ext
.end_do_label
!= gfc_statement_label
)
3849 gfc_error_now ("Statement label in END CRITICAL at %C does not "
3850 "match CRITICAL label");
3852 if (gfc_statement_label
!= NULL
)
3854 new_st
.op
= EXEC_NOP
;
3860 unexpected_statement (st
);
3864 while (st
!= ST_END_CRITICAL
);
3867 accept_statement (st
);
3871 /* Set up the local namespace for a BLOCK construct. */
3874 gfc_build_block_ns (gfc_namespace
*parent_ns
)
3876 gfc_namespace
* my_ns
;
3877 static int numblock
= 1;
3879 my_ns
= gfc_get_namespace (parent_ns
, 1);
3880 my_ns
->construct_entities
= 1;
3882 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3883 code generation (so it must not be NULL).
3884 We set its recursive argument if our container procedure is recursive, so
3885 that local variables are accordingly placed on the stack when it
3886 will be necessary. */
3888 my_ns
->proc_name
= gfc_new_block
;
3892 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
3894 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
3895 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
3896 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
3897 my_ns
->proc_name
->name
, NULL
);
3899 gfc_commit_symbol (my_ns
->proc_name
);
3902 if (parent_ns
->proc_name
)
3903 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
3909 /* Parse a BLOCK construct. */
3912 parse_block_construct (void)
3914 gfc_namespace
* my_ns
;
3917 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
3919 my_ns
= gfc_build_block_ns (gfc_current_ns
);
3921 new_st
.op
= EXEC_BLOCK
;
3922 new_st
.ext
.block
.ns
= my_ns
;
3923 new_st
.ext
.block
.assoc
= NULL
;
3924 accept_statement (ST_BLOCK
);
3926 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
3927 gfc_current_ns
= my_ns
;
3929 parse_progunit (ST_NONE
);
3931 gfc_current_ns
= gfc_current_ns
->parent
;
3936 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
3937 behind the scenes with compiler-generated variables. */
3940 parse_associate (void)
3942 gfc_namespace
* my_ns
;
3945 gfc_association_list
* a
;
3947 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
3949 my_ns
= gfc_build_block_ns (gfc_current_ns
);
3951 new_st
.op
= EXEC_BLOCK
;
3952 new_st
.ext
.block
.ns
= my_ns
;
3953 gcc_assert (new_st
.ext
.block
.assoc
);
3955 /* Add all associate-names as BLOCK variables. Creating them is enough
3956 for now, they'll get their values during trans-* phase. */
3957 gfc_current_ns
= my_ns
;
3958 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
3962 gfc_array_ref
*array_ref
;
3964 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
3968 sym
->attr
.flavor
= FL_VARIABLE
;
3970 sym
->declared_at
= a
->where
;
3971 gfc_set_sym_referenced (sym
);
3973 /* Initialize the typespec. It is not available in all cases,
3974 however, as it may only be set on the target during resolution.
3975 Still, sometimes it helps to have it right now -- especially
3976 for parsing component references on the associate-name
3977 in case of association to a derived-type. */
3978 sym
->ts
= a
->target
->ts
;
3980 /* Check if the target expression is array valued. This can not always
3981 be done by looking at target.rank, because that might not have been
3982 set yet. Therefore traverse the chain of refs, looking for the last
3983 array ref and evaluate that. */
3985 for (ref
= a
->target
->ref
; ref
; ref
= ref
->next
)
3986 if (ref
->type
== REF_ARRAY
)
3987 array_ref
= &ref
->u
.ar
;
3988 if (array_ref
|| a
->target
->rank
)
3994 /* Count the dimension, that have a non-scalar extend. */
3995 for (dim
= 0; dim
< array_ref
->dimen
; ++dim
)
3996 if (array_ref
->dimen_type
[dim
] != DIMEN_ELEMENT
3997 && !(array_ref
->dimen_type
[dim
] == DIMEN_UNKNOWN
3998 && array_ref
->end
[dim
] == NULL
3999 && array_ref
->start
[dim
] != NULL
))
4003 rank
= a
->target
->rank
;
4004 /* When the rank is greater than zero then sym will be an array. */
4005 if (sym
->ts
.type
== BT_CLASS
)
4007 if ((!CLASS_DATA (sym
)->as
&& rank
!= 0)
4008 || (CLASS_DATA (sym
)->as
4009 && CLASS_DATA (sym
)->as
->rank
!= rank
))
4011 /* Don't just (re-)set the attr and as in the sym.ts,
4012 because this modifies the target's attr and as. Copy the
4013 data and do a build_class_symbol. */
4014 symbol_attribute attr
= CLASS_DATA (a
->target
)->attr
;
4015 int corank
= gfc_get_corank (a
->target
);
4020 as
= gfc_get_array_spec ();
4021 as
->type
= AS_DEFERRED
;
4023 as
->corank
= corank
;
4024 attr
.dimension
= rank
? 1 : 0;
4025 attr
.codimension
= corank
? 1 : 0;
4030 attr
.dimension
= attr
.codimension
= 0;
4033 type
= CLASS_DATA (sym
)->ts
;
4034 if (!gfc_build_class_symbol (&type
,
4038 sym
->ts
.type
= BT_CLASS
;
4039 sym
->attr
.class_ok
= 1;
4042 sym
->attr
.class_ok
= 1;
4044 else if ((!sym
->as
&& rank
!= 0)
4045 || (sym
->as
&& sym
->as
->rank
!= rank
))
4047 as
= gfc_get_array_spec ();
4048 as
->type
= AS_DEFERRED
;
4050 as
->corank
= gfc_get_corank (a
->target
);
4052 sym
->attr
.dimension
= 1;
4054 sym
->attr
.codimension
= 1;
4059 accept_statement (ST_ASSOCIATE
);
4060 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
4063 st
= parse_executable (ST_NONE
);
4070 accept_statement (st
);
4071 my_ns
->code
= gfc_state_stack
->head
;
4075 unexpected_statement (st
);
4079 gfc_current_ns
= gfc_current_ns
->parent
;
4084 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
4085 handled inside of parse_executable(), because they aren't really
4089 parse_do_block (void)
4098 s
.ext
.end_do_label
= new_st
.label1
;
4100 if (new_st
.ext
.iterator
!= NULL
)
4101 stree
= new_st
.ext
.iterator
->var
->symtree
;
4105 accept_statement (ST_DO
);
4107 top
= gfc_state_stack
->tail
;
4108 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
4111 s
.do_variable
= stree
;
4113 top
->block
= new_level (top
);
4114 top
->block
->op
= EXEC_DO
;
4117 st
= parse_executable (ST_NONE
);
4125 if (s
.ext
.end_do_label
!= NULL
4126 && s
.ext
.end_do_label
!= gfc_statement_label
)
4127 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
4130 if (gfc_statement_label
!= NULL
)
4132 new_st
.op
= EXEC_NOP
;
4137 case ST_IMPLIED_ENDDO
:
4138 /* If the do-stmt of this DO construct has a do-construct-name,
4139 the corresponding end-do must be an end-do-stmt (with a matching
4140 name, but in that case we must have seen ST_ENDDO first).
4141 We only complain about this in pedantic mode. */
4142 if (gfc_current_block () != NULL
)
4143 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
4144 &gfc_current_block()->declared_at
);
4149 unexpected_statement (st
);
4154 accept_statement (st
);
4158 /* Parse the statements of OpenMP do/parallel do. */
4160 static gfc_statement
4161 parse_omp_do (gfc_statement omp_st
)
4167 accept_statement (omp_st
);
4169 cp
= gfc_state_stack
->tail
;
4170 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4171 np
= new_level (cp
);
4177 st
= next_statement ();
4180 else if (st
== ST_DO
)
4183 unexpected_statement (st
);
4187 if (gfc_statement_label
!= NULL
4188 && gfc_state_stack
->previous
!= NULL
4189 && gfc_state_stack
->previous
->state
== COMP_DO
4190 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4198 there should be no !$OMP END DO. */
4200 return ST_IMPLIED_ENDDO
;
4203 check_do_closure ();
4206 st
= next_statement ();
4207 gfc_statement omp_end_st
= ST_OMP_END_DO
;
4210 case ST_OMP_DISTRIBUTE
: omp_end_st
= ST_OMP_END_DISTRIBUTE
; break;
4211 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4212 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4214 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4215 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4217 case ST_OMP_DISTRIBUTE_SIMD
:
4218 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4220 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
4221 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
4222 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
4223 case ST_OMP_PARALLEL_DO_SIMD
:
4224 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
4226 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
4227 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4228 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4230 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4231 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4233 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4234 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4236 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4237 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4239 case ST_OMP_TEAMS_DISTRIBUTE
:
4240 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4242 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4243 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4245 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4246 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4248 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4249 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4251 default: gcc_unreachable ();
4253 if (st
== omp_end_st
)
4255 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
4256 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4258 gcc_assert (new_st
.op
== EXEC_NOP
);
4259 gfc_clear_new_st ();
4260 gfc_commit_symbols ();
4261 gfc_warning_check ();
4262 st
= next_statement ();
4268 /* Parse the statements of OpenMP atomic directive. */
4270 static gfc_statement
4271 parse_omp_atomic (void)
4278 accept_statement (ST_OMP_ATOMIC
);
4280 cp
= gfc_state_stack
->tail
;
4281 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4282 np
= new_level (cp
);
4285 count
= 1 + ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4286 == GFC_OMP_ATOMIC_CAPTURE
);
4290 st
= next_statement ();
4293 else if (st
== ST_ASSIGNMENT
)
4295 accept_statement (st
);
4299 unexpected_statement (st
);
4304 st
= next_statement ();
4305 if (st
== ST_OMP_END_ATOMIC
)
4307 gfc_clear_new_st ();
4308 gfc_commit_symbols ();
4309 gfc_warning_check ();
4310 st
= next_statement ();
4312 else if ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4313 == GFC_OMP_ATOMIC_CAPTURE
)
4314 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
4319 /* Parse the statements of an OpenACC structured block. */
4322 parse_oacc_structured_block (gfc_statement acc_st
)
4324 gfc_statement st
, acc_end_st
;
4326 gfc_state_data s
, *sd
;
4328 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4329 if (sd
->state
== COMP_CRITICAL
)
4330 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4332 accept_statement (acc_st
);
4334 cp
= gfc_state_stack
->tail
;
4335 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4336 np
= new_level (cp
);
4341 case ST_OACC_PARALLEL
:
4342 acc_end_st
= ST_OACC_END_PARALLEL
;
4344 case ST_OACC_KERNELS
:
4345 acc_end_st
= ST_OACC_END_KERNELS
;
4348 acc_end_st
= ST_OACC_END_DATA
;
4350 case ST_OACC_HOST_DATA
:
4351 acc_end_st
= ST_OACC_END_HOST_DATA
;
4359 st
= parse_executable (ST_NONE
);
4362 else if (st
!= acc_end_st
)
4363 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
4364 reject_statement ();
4366 while (st
!= acc_end_st
);
4368 gcc_assert (new_st
.op
== EXEC_NOP
);
4370 gfc_clear_new_st ();
4371 gfc_commit_symbols ();
4372 gfc_warning_check ();
4376 /* Parse the statements of OpenACC loop/parallel loop/kernels loop. */
4378 static gfc_statement
4379 parse_oacc_loop (gfc_statement acc_st
)
4383 gfc_state_data s
, *sd
;
4385 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4386 if (sd
->state
== COMP_CRITICAL
)
4387 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4389 accept_statement (acc_st
);
4391 cp
= gfc_state_stack
->tail
;
4392 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4393 np
= new_level (cp
);
4399 st
= next_statement ();
4402 else if (st
== ST_DO
)
4406 gfc_error ("Expected DO loop at %C");
4407 reject_statement ();
4412 if (gfc_statement_label
!= NULL
4413 && gfc_state_stack
->previous
!= NULL
4414 && gfc_state_stack
->previous
->state
== COMP_DO
4415 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4418 return ST_IMPLIED_ENDDO
;
4421 check_do_closure ();
4424 st
= next_statement ();
4425 if (st
== ST_OACC_END_LOOP
)
4426 gfc_warning (0, "Redundant !$ACC END LOOP at %C");
4427 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
4428 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
4429 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
4431 gcc_assert (new_st
.op
== EXEC_NOP
);
4432 gfc_clear_new_st ();
4433 gfc_commit_symbols ();
4434 gfc_warning_check ();
4435 st
= next_statement ();
4441 /* Parse the statements of an OpenMP structured block. */
4444 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
4446 gfc_statement st
, omp_end_st
;
4450 accept_statement (omp_st
);
4452 cp
= gfc_state_stack
->tail
;
4453 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4454 np
= new_level (cp
);
4460 case ST_OMP_PARALLEL
:
4461 omp_end_st
= ST_OMP_END_PARALLEL
;
4463 case ST_OMP_PARALLEL_SECTIONS
:
4464 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
4466 case ST_OMP_SECTIONS
:
4467 omp_end_st
= ST_OMP_END_SECTIONS
;
4469 case ST_OMP_ORDERED
:
4470 omp_end_st
= ST_OMP_END_ORDERED
;
4472 case ST_OMP_CRITICAL
:
4473 omp_end_st
= ST_OMP_END_CRITICAL
;
4476 omp_end_st
= ST_OMP_END_MASTER
;
4479 omp_end_st
= ST_OMP_END_SINGLE
;
4482 omp_end_st
= ST_OMP_END_TARGET
;
4484 case ST_OMP_TARGET_DATA
:
4485 omp_end_st
= ST_OMP_END_TARGET_DATA
;
4487 case ST_OMP_TARGET_TEAMS
:
4488 omp_end_st
= ST_OMP_END_TARGET_TEAMS
;
4490 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4491 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4493 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4494 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4496 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4497 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4499 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4500 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4503 omp_end_st
= ST_OMP_END_TASK
;
4505 case ST_OMP_TASKGROUP
:
4506 omp_end_st
= ST_OMP_END_TASKGROUP
;
4509 omp_end_st
= ST_OMP_END_TEAMS
;
4511 case ST_OMP_TEAMS_DISTRIBUTE
:
4512 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4514 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4515 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4517 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4518 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4520 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4521 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4523 case ST_OMP_DISTRIBUTE
:
4524 omp_end_st
= ST_OMP_END_DISTRIBUTE
;
4526 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4527 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4529 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4530 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4532 case ST_OMP_DISTRIBUTE_SIMD
:
4533 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4535 case ST_OMP_WORKSHARE
:
4536 omp_end_st
= ST_OMP_END_WORKSHARE
;
4538 case ST_OMP_PARALLEL_WORKSHARE
:
4539 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
4547 if (workshare_stmts_only
)
4549 /* Inside of !$omp workshare, only
4552 where statements and constructs
4553 forall statements and constructs
4557 are allowed. For !$omp critical these
4558 restrictions apply recursively. */
4561 st
= next_statement ();
4572 accept_statement (st
);
4575 case ST_WHERE_BLOCK
:
4576 parse_where_block ();
4579 case ST_FORALL_BLOCK
:
4580 parse_forall_block ();
4583 case ST_OMP_PARALLEL
:
4584 case ST_OMP_PARALLEL_SECTIONS
:
4585 parse_omp_structured_block (st
, false);
4588 case ST_OMP_PARALLEL_WORKSHARE
:
4589 case ST_OMP_CRITICAL
:
4590 parse_omp_structured_block (st
, true);
4593 case ST_OMP_PARALLEL_DO
:
4594 case ST_OMP_PARALLEL_DO_SIMD
:
4595 st
= parse_omp_do (st
);
4599 st
= parse_omp_atomic ();
4610 st
= next_statement ();
4614 st
= parse_executable (ST_NONE
);
4617 else if (st
== ST_OMP_SECTION
4618 && (omp_st
== ST_OMP_SECTIONS
4619 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
4621 np
= new_level (np
);
4625 else if (st
!= omp_end_st
)
4626 unexpected_statement (st
);
4628 while (st
!= omp_end_st
);
4632 case EXEC_OMP_END_NOWAIT
:
4633 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4635 case EXEC_OMP_CRITICAL
:
4636 if (((cp
->ext
.omp_name
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
4637 || (new_st
.ext
.omp_name
!= NULL
4638 && strcmp (cp
->ext
.omp_name
, new_st
.ext
.omp_name
) != 0))
4639 gfc_error ("Name after !$omp critical and !$omp end critical does "
4641 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
4643 case EXEC_OMP_END_SINGLE
:
4644 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
4645 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
4646 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
4647 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
4655 gfc_clear_new_st ();
4656 gfc_commit_symbols ();
4657 gfc_warning_check ();
4662 /* Accept a series of executable statements. We return the first
4663 statement that doesn't fit to the caller. Any block statements are
4664 passed on to the correct handler, which usually passes the buck
4667 static gfc_statement
4668 parse_executable (gfc_statement st
)
4673 st
= next_statement ();
4677 close_flag
= check_do_closure ();
4682 case ST_END_PROGRAM
:
4685 case ST_END_FUNCTION
:
4690 case ST_END_SUBROUTINE
:
4695 case ST_SELECT_CASE
:
4696 gfc_error ("%s statement at %C cannot terminate a non-block "
4697 "DO loop", gfc_ascii_statement (st
));
4710 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
4711 "first executable statement");
4717 accept_statement (st
);
4718 if (close_flag
== 1)
4719 return ST_IMPLIED_ENDDO
;
4723 parse_block_construct ();
4734 case ST_SELECT_CASE
:
4735 parse_select_block ();
4738 case ST_SELECT_TYPE
:
4739 parse_select_type_block();
4744 if (check_do_closure () == 1)
4745 return ST_IMPLIED_ENDDO
;
4749 parse_critical_block ();
4752 case ST_WHERE_BLOCK
:
4753 parse_where_block ();
4756 case ST_FORALL_BLOCK
:
4757 parse_forall_block ();
4760 case ST_OACC_PARALLEL_LOOP
:
4761 case ST_OACC_KERNELS_LOOP
:
4763 st
= parse_oacc_loop (st
);
4764 if (st
== ST_IMPLIED_ENDDO
)
4768 case ST_OACC_PARALLEL
:
4769 case ST_OACC_KERNELS
:
4771 case ST_OACC_HOST_DATA
:
4772 parse_oacc_structured_block (st
);
4775 case ST_OMP_PARALLEL
:
4776 case ST_OMP_PARALLEL_SECTIONS
:
4777 case ST_OMP_SECTIONS
:
4778 case ST_OMP_ORDERED
:
4779 case ST_OMP_CRITICAL
:
4783 case ST_OMP_TARGET_DATA
:
4784 case ST_OMP_TARGET_TEAMS
:
4787 case ST_OMP_TASKGROUP
:
4788 parse_omp_structured_block (st
, false);
4791 case ST_OMP_WORKSHARE
:
4792 case ST_OMP_PARALLEL_WORKSHARE
:
4793 parse_omp_structured_block (st
, true);
4796 case ST_OMP_DISTRIBUTE
:
4797 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4798 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4799 case ST_OMP_DISTRIBUTE_SIMD
:
4801 case ST_OMP_DO_SIMD
:
4802 case ST_OMP_PARALLEL_DO
:
4803 case ST_OMP_PARALLEL_DO_SIMD
:
4805 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4806 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4807 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4808 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4809 case ST_OMP_TEAMS_DISTRIBUTE
:
4810 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4811 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4812 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4813 st
= parse_omp_do (st
);
4814 if (st
== ST_IMPLIED_ENDDO
)
4819 st
= parse_omp_atomic ();
4826 st
= next_statement ();
4831 /* Fix the symbols for sibling functions. These are incorrectly added to
4832 the child namespace as the parser didn't know about this procedure. */
4835 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
4839 gfc_symbol
*old_sym
;
4841 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
4843 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
4845 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
4846 goto fixup_contained
;
4848 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
4849 && sym
->attr
.generic
&& sym
->attr
.function
)
4850 ||(sym
->attr
.flavor
== FL_DERIVED
4851 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
4852 goto fixup_contained
;
4854 old_sym
= st
->n
.sym
;
4855 if (old_sym
->ns
== ns
4856 && !old_sym
->attr
.contained
4858 /* By 14.6.1.3, host association should be excluded
4859 for the following. */
4860 && !(old_sym
->attr
.external
4861 || (old_sym
->ts
.type
!= BT_UNKNOWN
4862 && !old_sym
->attr
.implicit_type
)
4863 || old_sym
->attr
.flavor
== FL_PARAMETER
4864 || old_sym
->attr
.use_assoc
4865 || old_sym
->attr
.in_common
4866 || old_sym
->attr
.in_equivalence
4867 || old_sym
->attr
.data
4868 || old_sym
->attr
.dummy
4869 || old_sym
->attr
.result
4870 || old_sym
->attr
.dimension
4871 || old_sym
->attr
.allocatable
4872 || old_sym
->attr
.intrinsic
4873 || old_sym
->attr
.generic
4874 || old_sym
->attr
.flavor
== FL_NAMELIST
4875 || old_sym
->attr
.flavor
== FL_LABEL
4876 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
4878 /* Replace it with the symbol from the parent namespace. */
4882 gfc_release_symbol (old_sym
);
4886 /* Do the same for any contained procedures. */
4887 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
4892 parse_contained (int module
)
4894 gfc_namespace
*ns
, *parent_ns
, *tmp
;
4895 gfc_state_data s1
, s2
;
4899 int contains_statements
= 0;
4902 push_state (&s1
, COMP_CONTAINS
, NULL
);
4903 parent_ns
= gfc_current_ns
;
4907 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
4909 gfc_current_ns
->sibling
= parent_ns
->contained
;
4910 parent_ns
->contained
= gfc_current_ns
;
4913 /* Process the next available statement. We come here if we got an error
4914 and rejected the last statement. */
4915 st
= next_statement ();
4924 contains_statements
= 1;
4925 accept_statement (st
);
4928 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
4931 /* For internal procedures, create/update the symbol in the
4932 parent namespace. */
4936 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
4937 gfc_error ("Contained procedure %qs at %C is already "
4938 "ambiguous", gfc_new_block
->name
);
4941 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
4943 &gfc_new_block
->declared_at
))
4945 if (st
== ST_FUNCTION
)
4946 gfc_add_function (&sym
->attr
, sym
->name
,
4947 &gfc_new_block
->declared_at
);
4949 gfc_add_subroutine (&sym
->attr
, sym
->name
,
4950 &gfc_new_block
->declared_at
);
4954 gfc_commit_symbols ();
4957 sym
= gfc_new_block
;
4959 /* Mark this as a contained function, so it isn't replaced
4960 by other module functions. */
4961 sym
->attr
.contained
= 1;
4963 /* Set implicit_pure so that it can be reset if any of the
4964 tests for purity fail. This is used for some optimisation
4965 during translation. */
4966 if (!sym
->attr
.pure
)
4967 sym
->attr
.implicit_pure
= 1;
4969 parse_progunit (ST_NONE
);
4971 /* Fix up any sibling functions that refer to this one. */
4972 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
4973 /* Or refer to any of its alternate entry points. */
4974 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
4975 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
4977 gfc_current_ns
->code
= s2
.head
;
4978 gfc_current_ns
= parent_ns
;
4983 /* These statements are associated with the end of the host unit. */
4984 case ST_END_FUNCTION
:
4986 case ST_END_PROGRAM
:
4987 case ST_END_SUBROUTINE
:
4988 accept_statement (st
);
4989 gfc_current_ns
->code
= s1
.head
;
4993 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
4994 gfc_ascii_statement (st
));
4995 reject_statement ();
5001 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
5002 && st
!= ST_END_MODULE
&& st
!= ST_END_PROGRAM
);
5004 /* The first namespace in the list is guaranteed to not have
5005 anything (worthwhile) in it. */
5006 tmp
= gfc_current_ns
;
5007 gfc_current_ns
= parent_ns
;
5008 if (seen_error
&& tmp
->refs
> 1)
5009 gfc_free_namespace (tmp
);
5011 ns
= gfc_current_ns
->contained
;
5012 gfc_current_ns
->contained
= ns
->sibling
;
5013 gfc_free_namespace (ns
);
5016 if (!contains_statements
)
5017 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
5018 "FUNCTION or SUBROUTINE statement at %C");
5022 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
5025 parse_progunit (gfc_statement st
)
5030 st
= parse_spec (st
);
5037 /* This is not allowed within BLOCK! */
5038 if (gfc_current_state () != COMP_BLOCK
)
5043 accept_statement (st
);
5050 if (gfc_current_state () == COMP_FUNCTION
)
5051 gfc_check_function_type (gfc_current_ns
);
5056 st
= parse_executable (st
);
5064 /* This is not allowed within BLOCK! */
5065 if (gfc_current_state () != COMP_BLOCK
)
5070 accept_statement (st
);
5077 unexpected_statement (st
);
5078 reject_statement ();
5079 st
= next_statement ();
5085 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
5086 if (p
->state
== COMP_CONTAINS
)
5089 if (gfc_find_state (COMP_MODULE
) == true)
5094 gfc_error ("CONTAINS statement at %C is already in a contained "
5096 reject_statement ();
5097 st
= next_statement ();
5101 parse_contained (0);
5104 gfc_current_ns
->code
= gfc_state_stack
->head
;
5105 if (gfc_state_stack
->state
== COMP_PROGRAM
5106 || gfc_state_stack
->state
== COMP_MODULE
5107 || gfc_state_stack
->state
== COMP_SUBROUTINE
5108 || gfc_state_stack
->state
== COMP_FUNCTION
5109 || gfc_state_stack
->state
== COMP_BLOCK
)
5110 gfc_current_ns
->oacc_declare_clauses
5111 = gfc_state_stack
->ext
.oacc_declare_clauses
;
5115 /* Come here to complain about a global symbol already in use as
5119 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
5124 where
= &gfc_current_locus
;
5134 case GSYM_SUBROUTINE
:
5135 name
= "SUBROUTINE";
5140 case GSYM_BLOCK_DATA
:
5141 name
= "BLOCK DATA";
5147 gfc_internal_error ("gfc_global_used(): Bad type");
5151 if (sym
->binding_label
)
5152 gfc_error ("Global binding name %qs at %L is already being used as a %s "
5153 "at %L", sym
->binding_label
, where
, name
, &sym
->where
);
5155 gfc_error ("Global name %qs at %L is already being used as a %s at %L",
5156 sym
->name
, where
, name
, &sym
->where
);
5160 /* Parse a block data program unit. */
5163 parse_block_data (void)
5166 static locus blank_locus
;
5167 static int blank_block
=0;
5170 gfc_current_ns
->proc_name
= gfc_new_block
;
5171 gfc_current_ns
->is_block_data
= 1;
5173 if (gfc_new_block
== NULL
)
5176 gfc_error ("Blank BLOCK DATA at %C conflicts with "
5177 "prior BLOCK DATA at %L", &blank_locus
);
5181 blank_locus
= gfc_current_locus
;
5186 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5188 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
5189 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5192 s
->type
= GSYM_BLOCK_DATA
;
5193 s
->where
= gfc_new_block
->declared_at
;
5198 st
= parse_spec (ST_NONE
);
5200 while (st
!= ST_END_BLOCK_DATA
)
5202 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
5203 gfc_ascii_statement (st
));
5204 reject_statement ();
5205 st
= next_statement ();
5210 /* Parse a module subprogram. */
5219 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5220 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
5221 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5224 s
->type
= GSYM_MODULE
;
5225 s
->where
= gfc_new_block
->declared_at
;
5229 st
= parse_spec (ST_NONE
);
5239 parse_contained (1);
5243 accept_statement (st
);
5247 gfc_error ("Unexpected %s statement in MODULE at %C",
5248 gfc_ascii_statement (st
));
5251 reject_statement ();
5252 st
= next_statement ();
5256 /* Make sure not to free the namespace twice on error. */
5258 s
->ns
= gfc_current_ns
;
5262 /* Add a procedure name to the global symbol table. */
5265 add_global_procedure (bool sub
)
5269 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5270 name is a global identifier. */
5271 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5273 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5276 || (s
->type
!= GSYM_UNKNOWN
5277 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5279 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5280 /* Silence follow-up errors. */
5281 gfc_new_block
->binding_label
= NULL
;
5285 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5286 s
->sym_name
= gfc_new_block
->name
;
5287 s
->where
= gfc_new_block
->declared_at
;
5289 s
->ns
= gfc_current_ns
;
5293 /* Don't add the symbol multiple times. */
5294 if (gfc_new_block
->binding_label
5295 && (!gfc_notification_std (GFC_STD_F2008
)
5296 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
5298 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
);
5301 || (s
->type
!= GSYM_UNKNOWN
5302 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5304 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5305 /* Silence follow-up errors. */
5306 gfc_new_block
->binding_label
= NULL
;
5310 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5311 s
->sym_name
= gfc_new_block
->name
;
5312 s
->binding_label
= gfc_new_block
->binding_label
;
5313 s
->where
= gfc_new_block
->declared_at
;
5315 s
->ns
= gfc_current_ns
;
5321 /* Add a program to the global symbol table. */
5324 add_global_program (void)
5328 if (gfc_new_block
== NULL
)
5330 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5332 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
5333 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5336 s
->type
= GSYM_PROGRAM
;
5337 s
->where
= gfc_new_block
->declared_at
;
5339 s
->ns
= gfc_current_ns
;
5344 /* Resolve all the program units. */
5346 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
5348 gfc_free_dt_list ();
5349 gfc_current_ns
= gfc_global_ns_list
;
5350 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5352 if (gfc_current_ns
->proc_name
5353 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5354 continue; /* Already resolved. */
5356 if (gfc_current_ns
->proc_name
)
5357 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5358 gfc_resolve (gfc_current_ns
);
5359 gfc_current_ns
->derived_types
= gfc_derived_types
;
5360 gfc_derived_types
= NULL
;
5366 clean_up_modules (gfc_gsymbol
*gsym
)
5371 clean_up_modules (gsym
->left
);
5372 clean_up_modules (gsym
->right
);
5374 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
5377 gfc_current_ns
= gsym
->ns
;
5378 gfc_derived_types
= gfc_current_ns
->derived_types
;
5385 /* Translate all the program units. This could be in a different order
5386 to resolution if there are forward references in the file. */
5388 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
5392 gfc_current_ns
= gfc_global_ns_list
;
5393 gfc_get_errors (NULL
, &errors
);
5395 /* We first translate all modules to make sure that later parts
5396 of the program can use the decl. Then we translate the nonmodules. */
5398 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5400 if (!gfc_current_ns
->proc_name
5401 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5404 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5405 gfc_derived_types
= gfc_current_ns
->derived_types
;
5406 gfc_generate_module_code (gfc_current_ns
);
5407 gfc_current_ns
->translated
= 1;
5410 gfc_current_ns
= gfc_global_ns_list
;
5411 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5413 if (gfc_current_ns
->proc_name
5414 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5417 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5418 gfc_derived_types
= gfc_current_ns
->derived_types
;
5419 gfc_generate_code (gfc_current_ns
);
5420 gfc_current_ns
->translated
= 1;
5423 /* Clean up all the namespaces after translation. */
5424 gfc_current_ns
= gfc_global_ns_list
;
5425 for (;gfc_current_ns
;)
5429 if (gfc_current_ns
->proc_name
5430 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5432 gfc_current_ns
= gfc_current_ns
->sibling
;
5436 ns
= gfc_current_ns
->sibling
;
5437 gfc_derived_types
= gfc_current_ns
->derived_types
;
5439 gfc_current_ns
= ns
;
5442 clean_up_modules (gfc_gsym_root
);
5446 /* Top level parser. */
5449 gfc_parse_file (void)
5451 int seen_program
, errors_before
, errors
;
5452 gfc_state_data top
, s
;
5455 gfc_namespace
*next
;
5457 gfc_start_source_files ();
5459 top
.state
= COMP_NONE
;
5461 top
.previous
= NULL
;
5462 top
.head
= top
.tail
= NULL
;
5463 top
.do_variable
= NULL
;
5465 gfc_state_stack
= &top
;
5467 gfc_clear_new_st ();
5469 gfc_statement_label
= NULL
;
5471 if (setjmp (eof_buf
))
5472 return false; /* Come here on unexpected EOF */
5474 /* Prepare the global namespace that will contain the
5476 gfc_global_ns_list
= next
= NULL
;
5481 /* Exit early for empty files. */
5487 st
= next_statement ();
5496 goto duplicate_main
;
5498 prog_locus
= gfc_current_locus
;
5500 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
5501 main_program_symbol(gfc_current_ns
, gfc_new_block
->name
);
5502 accept_statement (st
);
5503 add_global_program ();
5504 parse_progunit (ST_NONE
);
5509 add_global_procedure (true);
5510 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
5511 accept_statement (st
);
5512 parse_progunit (ST_NONE
);
5517 add_global_procedure (false);
5518 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
5519 accept_statement (st
);
5520 parse_progunit (ST_NONE
);
5525 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
5526 accept_statement (st
);
5527 parse_block_data ();
5531 push_state (&s
, COMP_MODULE
, gfc_new_block
);
5532 accept_statement (st
);
5534 gfc_get_errors (NULL
, &errors_before
);
5538 /* Anything else starts a nameless main program block. */
5541 goto duplicate_main
;
5543 prog_locus
= gfc_current_locus
;
5545 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
5546 main_program_symbol (gfc_current_ns
, "MAIN__");
5547 parse_progunit (st
);
5552 /* Handle the non-program units. */
5553 gfc_current_ns
->code
= s
.head
;
5555 gfc_resolve (gfc_current_ns
);
5557 /* Dump the parse tree if requested. */
5558 if (flag_dump_fortran_original
)
5559 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
5561 gfc_get_errors (NULL
, &errors
);
5562 if (s
.state
== COMP_MODULE
)
5564 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
5565 gfc_current_ns
->derived_types
= gfc_derived_types
;
5566 gfc_derived_types
= NULL
;
5572 gfc_generate_code (gfc_current_ns
);
5580 /* The main program and non-contained procedures are put
5581 in the global namespace list, so that they can be processed
5582 later and all their interfaces resolved. */
5583 gfc_current_ns
->code
= s
.head
;
5586 for (; next
->sibling
; next
= next
->sibling
)
5588 next
->sibling
= gfc_current_ns
;
5591 gfc_global_ns_list
= gfc_current_ns
;
5593 next
= gfc_current_ns
;
5600 /* Do the resolution. */
5601 resolve_all_program_units (gfc_global_ns_list
);
5603 /* Do the parse tree dump. */
5605 = flag_dump_fortran_original
? gfc_global_ns_list
: NULL
;
5607 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5608 if (!gfc_current_ns
->proc_name
5609 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5611 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
5612 fputs ("------------------------------------------\n\n", stdout
);
5615 /* Do the translation. */
5616 translate_all_program_units (gfc_global_ns_list
);
5618 gfc_end_source_files ();
5622 /* If we see a duplicate main program, shut down. If the second
5623 instance is an implied main program, i.e. data decls or executable
5624 statements, we're in for lots of errors. */
5625 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
5626 reject_statement ();
5631 /* Return true if this state data represents an OpenACC region. */
5633 is_oacc (gfc_state_data
*sd
)
5635 switch (sd
->construct
->op
)
5637 case EXEC_OACC_PARALLEL_LOOP
:
5638 case EXEC_OACC_PARALLEL
:
5639 case EXEC_OACC_KERNELS_LOOP
:
5640 case EXEC_OACC_KERNELS
:
5641 case EXEC_OACC_DATA
:
5642 case EXEC_OACC_HOST_DATA
:
5643 case EXEC_OACC_LOOP
:
5644 case EXEC_OACC_UPDATE
:
5645 case EXEC_OACC_WAIT
:
5646 case EXEC_OACC_CACHE
:
5647 case EXEC_OACC_ENTER_DATA
:
5648 case EXEC_OACC_EXIT_DATA
: