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 if (gfc_match_submod_proc () == MATCH_YES
)
374 if (gfc_new_block
->attr
.subroutine
)
375 return ST_SUBROUTINE
;
376 else if (gfc_new_block
->attr
.function
)
380 gfc_current_locus
= old_locus
;
382 /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
383 statements, which might begin with a block label. The match functions for
384 these statements are unusual in that their keyword is not seen before
385 the matcher is called. */
387 if (gfc_match_if (&st
) == MATCH_YES
)
390 gfc_current_locus
= old_locus
;
392 if (gfc_match_where (&st
) == MATCH_YES
)
395 gfc_current_locus
= old_locus
;
397 if (gfc_match_forall (&st
) == MATCH_YES
)
400 gfc_current_locus
= old_locus
;
402 match (NULL
, gfc_match_do
, ST_DO
);
403 match (NULL
, gfc_match_block
, ST_BLOCK
);
404 match (NULL
, gfc_match_associate
, ST_ASSOCIATE
);
405 match (NULL
, gfc_match_critical
, ST_CRITICAL
);
406 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
408 gfc_current_ns
= gfc_build_block_ns (gfc_current_ns
);
409 match (NULL
, gfc_match_select_type
, ST_SELECT_TYPE
);
411 gfc_current_ns
= gfc_current_ns
->parent
;
412 gfc_free_namespace (ns
);
414 /* General statement matching: Instead of testing every possible
415 statement, we eliminate most possibilities by peeking at the
421 match ("abstract% interface", gfc_match_abstract_interface
,
423 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
424 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
425 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
426 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
430 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
431 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
432 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
436 match ("call", gfc_match_call
, ST_CALL
);
437 match ("close", gfc_match_close
, ST_CLOSE
);
438 match ("continue", gfc_match_continue
, ST_CONTINUE
);
439 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
440 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
441 match ("case", gfc_match_case
, ST_CASE
);
442 match ("common", gfc_match_common
, ST_COMMON
);
443 match ("contains", gfc_match_eos
, ST_CONTAINS
);
444 match ("class", gfc_match_class_is
, ST_CLASS_IS
);
445 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
449 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
450 match ("data", gfc_match_data
, ST_DATA
);
451 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
455 match ("end file", gfc_match_endfile
, ST_END_FILE
);
456 match ("exit", gfc_match_exit
, ST_EXIT
);
457 match ("else", gfc_match_else
, ST_ELSE
);
458 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
459 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
460 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
);
461 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
463 if (gfc_match_end (&st
) == MATCH_YES
)
466 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
467 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
468 match ("external", gfc_match_external
, ST_ATTR_DECL
);
472 match ("final", gfc_match_final_decl
, ST_FINAL
);
473 match ("flush", gfc_match_flush
, ST_FLUSH
);
474 match ("format", gfc_match_format
, ST_FORMAT
);
478 match ("generic", gfc_match_generic
, ST_GENERIC
);
479 match ("go to", gfc_match_goto
, ST_GOTO
);
483 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
484 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
485 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
486 match ("import", gfc_match_import
, ST_IMPORT
);
487 match ("interface", gfc_match_interface
, ST_INTERFACE
);
488 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
489 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
493 match ("lock", gfc_match_lock
, ST_LOCK
);
497 match ("module% procedure", gfc_match_modproc
, ST_MODULE_PROC
);
498 match ("module", gfc_match_module
, ST_MODULE
);
502 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
503 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
507 match ("open", gfc_match_open
, ST_OPEN
);
508 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
512 match ("print", gfc_match_print
, ST_WRITE
);
513 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
514 match ("pause", gfc_match_pause
, ST_PAUSE
);
515 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
516 if (gfc_match_private (&st
) == MATCH_YES
)
518 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
519 match ("program", gfc_match_program
, ST_PROGRAM
);
520 if (gfc_match_public (&st
) == MATCH_YES
)
522 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
526 match ("read", gfc_match_read
, ST_READ
);
527 match ("return", gfc_match_return
, ST_RETURN
);
528 match ("rewind", gfc_match_rewind
, ST_REWIND
);
532 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
533 match ("stop", gfc_match_stop
, ST_STOP
);
534 match ("save", gfc_match_save
, ST_ATTR_DECL
);
535 match ("submodule", gfc_match_submodule
, ST_SUBMODULE
);
536 match ("sync all", gfc_match_sync_all
, ST_SYNC_ALL
);
537 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
538 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
542 match ("target", gfc_match_target
, ST_ATTR_DECL
);
543 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
544 match ("type is", gfc_match_type_is
, ST_TYPE_IS
);
548 match ("unlock", gfc_match_unlock
, ST_UNLOCK
);
552 match ("value", gfc_match_value
, ST_ATTR_DECL
);
553 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
557 match ("wait", gfc_match_wait
, ST_WAIT
);
558 match ("write", gfc_match_write
, ST_WRITE
);
562 /* All else has failed, so give up. See if any of the matchers has
563 stored an error message of some sort. */
565 if (!gfc_error_check ())
566 gfc_error_now ("Unclassifiable statement at %C");
570 gfc_error_recovery ();
575 /* Like match, but set a flag simd_matched if keyword matched. */
576 #define matchs(keyword, subr, st) \
578 if (match_word_omp_simd (keyword, subr, &old_locus, \
579 &simd_matched) == MATCH_YES) \
582 undo_new_statement (); \
585 /* Like match, but don't match anything if not -fopenmp. */
586 #define matcho(keyword, subr, st) \
590 else if (match_word (keyword, subr, &old_locus) \
594 undo_new_statement (); \
598 decode_oacc_directive (void)
603 gfc_enforce_clean_symbol_state ();
605 gfc_clear_error (); /* Clear any pending errors. */
606 gfc_clear_warning (); /* Clear any pending warnings. */
610 gfc_error_now ("OpenACC directives at %C may not appear in PURE "
612 gfc_error_recovery ();
616 gfc_unset_implicit_pure (NULL
);
618 old_locus
= gfc_current_locus
;
620 /* General OpenACC directive matching: Instead of testing every possible
621 statement, we eliminate most possibilities by peeking at the
624 c
= gfc_peek_ascii_char ();
629 match ("cache", gfc_match_oacc_cache
, ST_OACC_CACHE
);
632 match ("data", gfc_match_oacc_data
, ST_OACC_DATA
);
633 match ("declare", gfc_match_oacc_declare
, ST_OACC_DECLARE
);
636 match ("end data", gfc_match_omp_eos
, ST_OACC_END_DATA
);
637 match ("end host_data", gfc_match_omp_eos
, ST_OACC_END_HOST_DATA
);
638 match ("end kernels loop", gfc_match_omp_eos
, ST_OACC_END_KERNELS_LOOP
);
639 match ("end kernels", gfc_match_omp_eos
, ST_OACC_END_KERNELS
);
640 match ("end loop", gfc_match_omp_eos
, ST_OACC_END_LOOP
);
641 match ("end parallel loop", gfc_match_omp_eos
, ST_OACC_END_PARALLEL_LOOP
);
642 match ("end parallel", gfc_match_omp_eos
, ST_OACC_END_PARALLEL
);
643 match ("enter data", gfc_match_oacc_enter_data
, ST_OACC_ENTER_DATA
);
644 match ("exit data", gfc_match_oacc_exit_data
, ST_OACC_EXIT_DATA
);
647 match ("host_data", gfc_match_oacc_host_data
, ST_OACC_HOST_DATA
);
650 match ("parallel loop", gfc_match_oacc_parallel_loop
, ST_OACC_PARALLEL_LOOP
);
651 match ("parallel", gfc_match_oacc_parallel
, ST_OACC_PARALLEL
);
654 match ("kernels loop", gfc_match_oacc_kernels_loop
, ST_OACC_KERNELS_LOOP
);
655 match ("kernels", gfc_match_oacc_kernels
, ST_OACC_KERNELS
);
658 match ("loop", gfc_match_oacc_loop
, ST_OACC_LOOP
);
661 match ("routine", gfc_match_oacc_routine
, ST_OACC_ROUTINE
);
664 match ("update", gfc_match_oacc_update
, ST_OACC_UPDATE
);
667 match ("wait", gfc_match_oacc_wait
, ST_OACC_WAIT
);
671 /* Directive not found or stored an error message.
672 Check and give up. */
674 if (gfc_error_check () == 0)
675 gfc_error_now ("Unclassifiable OpenACC directive at %C");
679 gfc_error_recovery ();
685 decode_omp_directive (void)
689 bool simd_matched
= false;
691 gfc_enforce_clean_symbol_state ();
693 gfc_clear_error (); /* Clear any pending errors. */
694 gfc_clear_warning (); /* Clear any pending warnings. */
698 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
699 "or ELEMENTAL procedures");
700 gfc_error_recovery ();
704 gfc_unset_implicit_pure (NULL
);
706 old_locus
= gfc_current_locus
;
708 /* General OpenMP directive matching: Instead of testing every possible
709 statement, we eliminate most possibilities by peeking at the
712 c
= gfc_peek_ascii_char ();
714 /* match is for directives that should be recognized only if
715 -fopenmp, matchs for directives that should be recognized
716 if either -fopenmp or -fopenmp-simd. */
720 matcho ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
723 matcho ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
726 matcho ("cancellation% point", gfc_match_omp_cancellation_point
,
727 ST_OMP_CANCELLATION_POINT
);
728 matcho ("cancel", gfc_match_omp_cancel
, ST_OMP_CANCEL
);
729 matcho ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
732 matchs ("declare reduction", gfc_match_omp_declare_reduction
,
733 ST_OMP_DECLARE_REDUCTION
);
734 matchs ("declare simd", gfc_match_omp_declare_simd
,
735 ST_OMP_DECLARE_SIMD
);
736 matcho ("declare target", gfc_match_omp_declare_target
,
737 ST_OMP_DECLARE_TARGET
);
738 matchs ("distribute parallel do simd",
739 gfc_match_omp_distribute_parallel_do_simd
,
740 ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
);
741 matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do
,
742 ST_OMP_DISTRIBUTE_PARALLEL_DO
);
743 matchs ("distribute simd", gfc_match_omp_distribute_simd
,
744 ST_OMP_DISTRIBUTE_SIMD
);
745 matcho ("distribute", gfc_match_omp_distribute
, ST_OMP_DISTRIBUTE
);
746 matchs ("do simd", gfc_match_omp_do_simd
, ST_OMP_DO_SIMD
);
747 matcho ("do", gfc_match_omp_do
, ST_OMP_DO
);
750 matcho ("end atomic", gfc_match_omp_eos
, ST_OMP_END_ATOMIC
);
751 matcho ("end critical", gfc_match_omp_critical
, ST_OMP_END_CRITICAL
);
752 matchs ("end distribute parallel do simd", gfc_match_omp_eos
,
753 ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
);
754 matcho ("end distribute parallel do", gfc_match_omp_eos
,
755 ST_OMP_END_DISTRIBUTE_PARALLEL_DO
);
756 matchs ("end distribute simd", gfc_match_omp_eos
,
757 ST_OMP_END_DISTRIBUTE_SIMD
);
758 matcho ("end distribute", gfc_match_omp_eos
, ST_OMP_END_DISTRIBUTE
);
759 matchs ("end do simd", gfc_match_omp_end_nowait
, ST_OMP_END_DO_SIMD
);
760 matcho ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
761 matchs ("end simd", gfc_match_omp_eos
, ST_OMP_END_SIMD
);
762 matcho ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
763 matcho ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
764 matchs ("end parallel do simd", gfc_match_omp_eos
,
765 ST_OMP_END_PARALLEL_DO_SIMD
);
766 matcho ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
767 matcho ("end parallel sections", gfc_match_omp_eos
,
768 ST_OMP_END_PARALLEL_SECTIONS
);
769 matcho ("end parallel workshare", gfc_match_omp_eos
,
770 ST_OMP_END_PARALLEL_WORKSHARE
);
771 matcho ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
772 matcho ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
773 matcho ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
774 matcho ("end target data", gfc_match_omp_eos
, ST_OMP_END_TARGET_DATA
);
775 matchs ("end target teams distribute parallel do simd",
777 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
778 matcho ("end target teams distribute parallel do", gfc_match_omp_eos
,
779 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
780 matchs ("end target teams distribute simd", gfc_match_omp_eos
,
781 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
);
782 matcho ("end target teams distribute", gfc_match_omp_eos
,
783 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
);
784 matcho ("end target teams", gfc_match_omp_eos
, ST_OMP_END_TARGET_TEAMS
);
785 matcho ("end target", gfc_match_omp_eos
, ST_OMP_END_TARGET
);
786 matcho ("end taskgroup", gfc_match_omp_eos
, ST_OMP_END_TASKGROUP
);
787 matcho ("end task", gfc_match_omp_eos
, ST_OMP_END_TASK
);
788 matchs ("end teams distribute parallel do simd", gfc_match_omp_eos
,
789 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
790 matcho ("end teams distribute parallel do", gfc_match_omp_eos
,
791 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
);
792 matchs ("end teams distribute simd", gfc_match_omp_eos
,
793 ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
);
794 matcho ("end teams distribute", gfc_match_omp_eos
,
795 ST_OMP_END_TEAMS_DISTRIBUTE
);
796 matcho ("end teams", gfc_match_omp_eos
, ST_OMP_END_TEAMS
);
797 matcho ("end workshare", gfc_match_omp_end_nowait
,
798 ST_OMP_END_WORKSHARE
);
801 matcho ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
804 matcho ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
807 matcho ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
810 matchs ("parallel do simd", gfc_match_omp_parallel_do_simd
,
811 ST_OMP_PARALLEL_DO_SIMD
);
812 matcho ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
813 matcho ("parallel sections", gfc_match_omp_parallel_sections
,
814 ST_OMP_PARALLEL_SECTIONS
);
815 matcho ("parallel workshare", gfc_match_omp_parallel_workshare
,
816 ST_OMP_PARALLEL_WORKSHARE
);
817 matcho ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
820 matcho ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
821 matcho ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
822 matchs ("simd", gfc_match_omp_simd
, ST_OMP_SIMD
);
823 matcho ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
826 matcho ("target data", gfc_match_omp_target_data
, ST_OMP_TARGET_DATA
);
827 matchs ("target teams distribute parallel do simd",
828 gfc_match_omp_target_teams_distribute_parallel_do_simd
,
829 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
830 matcho ("target teams distribute parallel do",
831 gfc_match_omp_target_teams_distribute_parallel_do
,
832 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
833 matchs ("target teams distribute simd",
834 gfc_match_omp_target_teams_distribute_simd
,
835 ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
);
836 matcho ("target teams distribute", gfc_match_omp_target_teams_distribute
,
837 ST_OMP_TARGET_TEAMS_DISTRIBUTE
);
838 matcho ("target teams", gfc_match_omp_target_teams
, ST_OMP_TARGET_TEAMS
);
839 matcho ("target update", gfc_match_omp_target_update
,
840 ST_OMP_TARGET_UPDATE
);
841 matcho ("target", gfc_match_omp_target
, ST_OMP_TARGET
);
842 matcho ("taskgroup", gfc_match_omp_taskgroup
, ST_OMP_TASKGROUP
);
843 matcho ("taskwait", gfc_match_omp_taskwait
, ST_OMP_TASKWAIT
);
844 matcho ("taskyield", gfc_match_omp_taskyield
, ST_OMP_TASKYIELD
);
845 matcho ("task", gfc_match_omp_task
, ST_OMP_TASK
);
846 matchs ("teams distribute parallel do simd",
847 gfc_match_omp_teams_distribute_parallel_do_simd
,
848 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
849 matcho ("teams distribute parallel do",
850 gfc_match_omp_teams_distribute_parallel_do
,
851 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
);
852 matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd
,
853 ST_OMP_TEAMS_DISTRIBUTE_SIMD
);
854 matcho ("teams distribute", gfc_match_omp_teams_distribute
,
855 ST_OMP_TEAMS_DISTRIBUTE
);
856 matcho ("teams", gfc_match_omp_teams
, ST_OMP_TEAMS
);
857 matcho ("threadprivate", gfc_match_omp_threadprivate
,
858 ST_OMP_THREADPRIVATE
);
861 matcho ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
865 /* All else has failed, so give up. See if any of the matchers has
866 stored an error message of some sort. Don't error out if
867 not -fopenmp and simd_matched is false, i.e. if a directive other
868 than one marked with match has been seen. */
870 if (flag_openmp
|| simd_matched
)
872 if (!gfc_error_check ())
873 gfc_error_now ("Unclassifiable OpenMP directive at %C");
878 gfc_error_recovery ();
884 decode_gcc_attribute (void)
888 gfc_enforce_clean_symbol_state ();
890 gfc_clear_error (); /* Clear any pending errors. */
891 gfc_clear_warning (); /* Clear any pending warnings. */
892 old_locus
= gfc_current_locus
;
894 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
896 /* All else has failed, so give up. See if any of the matchers has
897 stored an error message of some sort. */
899 if (!gfc_error_check ())
900 gfc_error_now ("Unclassifiable GCC directive at %C");
904 gfc_error_recovery ();
911 /* Assert next length characters to be equal to token in free form. */
914 verify_token_free (const char* token
, int length
, bool last_was_use_stmt
)
919 c
= gfc_next_ascii_char ();
920 for (i
= 0; i
< length
; i
++, c
= gfc_next_ascii_char ())
921 gcc_assert (c
== token
[i
]);
923 gcc_assert (gfc_is_whitespace(c
));
924 gfc_gobble_whitespace ();
925 if (last_was_use_stmt
)
929 /* Get the next statement in free form source. */
938 at_bol
= gfc_at_bol ();
939 gfc_gobble_whitespace ();
941 c
= gfc_peek_ascii_char ();
947 /* Found a statement label? */
948 m
= gfc_match_st_label (&gfc_statement_label
);
950 d
= gfc_peek_ascii_char ();
951 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
953 gfc_match_small_literal_int (&i
, &cnt
);
956 gfc_error_now ("Too many digits in statement label at %C");
959 gfc_error_now ("Zero is not a valid statement label at %C");
962 c
= gfc_next_ascii_char ();
965 if (!gfc_is_whitespace (c
))
966 gfc_error_now ("Non-numeric character in statement label at %C");
972 label_locus
= gfc_current_locus
;
974 gfc_gobble_whitespace ();
976 if (at_bol
&& gfc_peek_ascii_char () == ';')
978 gfc_error_now ("Semicolon at %C needs to be preceded by "
980 gfc_next_ascii_char (); /* Eat up the semicolon. */
984 if (gfc_match_eos () == MATCH_YES
)
986 gfc_warning_now (0, "Ignoring statement label in empty statement "
987 "at %L", &label_locus
);
988 gfc_free_st_label (gfc_statement_label
);
989 gfc_statement_label
= NULL
;
996 /* Comments have already been skipped by the time we get here,
997 except for GCC attributes and OpenMP/OpenACC directives. */
999 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
1000 c
= gfc_peek_ascii_char ();
1006 c
= gfc_next_ascii_char ();
1007 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
1008 gcc_assert (c
== "gcc$"[i
]);
1010 gfc_gobble_whitespace ();
1011 return decode_gcc_attribute ();
1016 /* Since both OpenMP and OpenACC directives starts with
1017 !$ character sequence, we must check all flags combinations */
1018 if ((flag_openmp
|| flag_openmp_simd
)
1021 verify_token_free ("$omp", 4, last_was_use_stmt
);
1022 return decode_omp_directive ();
1024 else if ((flag_openmp
|| flag_openmp_simd
)
1027 gfc_next_ascii_char (); /* Eat up dollar character */
1028 c
= gfc_peek_ascii_char ();
1032 verify_token_free ("omp", 3, last_was_use_stmt
);
1033 return decode_omp_directive ();
1037 verify_token_free ("acc", 3, last_was_use_stmt
);
1038 return decode_oacc_directive ();
1041 else if (flag_openacc
)
1043 verify_token_free ("$acc", 4, last_was_use_stmt
);
1044 return decode_oacc_directive ();
1050 if (at_bol
&& c
== ';')
1052 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1053 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1055 gfc_next_ascii_char (); /* Eat up the semicolon. */
1059 return decode_statement ();
1062 /* Assert next length characters to be equal to token in fixed form. */
1065 verify_token_fixed (const char *token
, int length
, bool last_was_use_stmt
)
1068 char c
= gfc_next_char_literal (NONSTRING
);
1070 for (i
= 0; i
< length
; i
++, c
= gfc_next_char_literal (NONSTRING
))
1071 gcc_assert ((char) gfc_wide_tolower (c
) == token
[i
]);
1073 if (c
!= ' ' && c
!= '0')
1075 gfc_buffer_error (false);
1076 gfc_error ("Bad continuation line at %C");
1079 if (last_was_use_stmt
)
1085 /* Get the next statement in fixed-form source. */
1087 static gfc_statement
1090 int label
, digit_flag
, i
;
1095 return decode_statement ();
1097 /* Skip past the current label field, parsing a statement label if
1098 one is there. This is a weird number parser, since the number is
1099 contained within five columns and can have any kind of embedded
1100 spaces. We also check for characters that make the rest of the
1106 for (i
= 0; i
< 5; i
++)
1108 c
= gfc_next_char_literal (NONSTRING
);
1125 label
= label
* 10 + ((unsigned char) c
- '0');
1126 label_locus
= gfc_current_locus
;
1130 /* Comments have already been skipped by the time we get
1131 here, except for GCC attributes and OpenMP directives. */
1134 c
= gfc_next_char_literal (NONSTRING
);
1136 if (TOLOWER (c
) == 'g')
1138 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
1139 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
1141 return decode_gcc_attribute ();
1145 if ((flag_openmp
|| flag_openmp_simd
)
1148 if (!verify_token_fixed ("omp", 3, last_was_use_stmt
))
1150 return decode_omp_directive ();
1152 else if ((flag_openmp
|| flag_openmp_simd
)
1155 c
= gfc_next_char_literal(NONSTRING
);
1156 if (c
== 'o' || c
== 'O')
1158 if (!verify_token_fixed ("mp", 2, last_was_use_stmt
))
1160 return decode_omp_directive ();
1162 else if (c
== 'a' || c
== 'A')
1164 if (!verify_token_fixed ("cc", 2, last_was_use_stmt
))
1166 return decode_oacc_directive ();
1169 else if (flag_openacc
)
1171 if (!verify_token_fixed ("acc", 3, last_was_use_stmt
))
1173 return decode_oacc_directive ();
1178 /* Comments have already been skipped by the time we get
1179 here so don't bother checking for them. */
1182 gfc_buffer_error (false);
1183 gfc_error ("Non-numeric character in statement label at %C");
1191 gfc_warning_now (0, "Zero is not a valid statement label at %C");
1194 /* We've found a valid statement label. */
1195 gfc_statement_label
= gfc_get_st_label (label
);
1199 /* Since this line starts a statement, it cannot be a continuation
1200 of a previous statement. If we see something here besides a
1201 space or zero, it must be a bad continuation line. */
1203 c
= gfc_next_char_literal (NONSTRING
);
1207 if (c
!= ' ' && c
!= '0')
1209 gfc_buffer_error (false);
1210 gfc_error ("Bad continuation line at %C");
1214 /* Now that we've taken care of the statement label columns, we have
1215 to make sure that the first nonblank character is not a '!'. If
1216 it is, the rest of the line is a comment. */
1220 loc
= gfc_current_locus
;
1221 c
= gfc_next_char_literal (NONSTRING
);
1223 while (gfc_is_whitespace (c
));
1227 gfc_current_locus
= loc
;
1232 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1233 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1234 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1239 if (gfc_match_eos () == MATCH_YES
)
1242 /* At this point, we've got a nonblank statement to parse. */
1243 return decode_statement ();
1247 gfc_warning_now (0, "Ignoring statement label in empty statement at %L",
1250 gfc_current_locus
.lb
->truncated
= 0;
1251 gfc_advance_line ();
1256 /* Return the next non-ST_NONE statement to the caller. We also worry
1257 about including files and the ends of include files at this stage. */
1259 static gfc_statement
1260 next_statement (void)
1265 gfc_enforce_clean_symbol_state ();
1267 gfc_new_block
= NULL
;
1269 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
1270 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1271 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
1274 gfc_statement_label
= NULL
;
1275 gfc_buffer_error (true);
1278 gfc_advance_line ();
1280 gfc_skip_comments ();
1288 if (gfc_define_undef_line ())
1291 old_locus
= gfc_current_locus
;
1293 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1299 gfc_buffer_error (false);
1301 if (st
== ST_GET_FCN_CHARACTERISTICS
&& gfc_statement_label
!= NULL
)
1303 gfc_free_st_label (gfc_statement_label
);
1304 gfc_statement_label
= NULL
;
1305 gfc_current_locus
= old_locus
;
1309 check_statement_label (st
);
1315 /****************************** Parser ***********************************/
1317 /* The parser subroutines are of type 'try' that fail if the file ends
1320 /* Macros that expand to case-labels for various classes of
1321 statements. Start with executable statements that directly do
1324 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1325 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1326 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1327 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1328 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1329 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1330 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1331 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1332 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1333 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
1334 case ST_OMP_TARGET_UPDATE: case ST_ERROR_STOP: case ST_SYNC_ALL: \
1335 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1336 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1337 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1339 /* Statements that mark other executable statements. */
1341 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1342 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1343 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1344 case ST_OMP_PARALLEL: \
1345 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1346 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
1347 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1348 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1349 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1350 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1351 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1352 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1353 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1354 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1355 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1356 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1357 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1358 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1359 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1360 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1361 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: \
1363 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1364 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: case ST_OACC_KERNELS_LOOP
1366 /* Declaration statements */
1368 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1369 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1370 case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
1371 case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD: case ST_OMP_DECLARE_REDUCTION: \
1372 case ST_OMP_DECLARE_TARGET: case ST_OACC_ROUTINE
1374 /* Block end statements. Errors associated with interchanging these
1375 are detected in gfc_match_end(). */
1377 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1378 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1379 case ST_END_BLOCK: case ST_END_ASSOCIATE
1382 /* Push a new state onto the stack. */
1385 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1387 p
->state
= new_state
;
1388 p
->previous
= gfc_state_stack
;
1390 p
->head
= p
->tail
= NULL
;
1391 p
->do_variable
= NULL
;
1392 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1393 p
->ext
.oacc_declare_clauses
= NULL
;
1395 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1396 construct statement was accepted right before pushing the state. Thus,
1397 the construct's gfc_code is available as tail of the parent state. */
1398 gcc_assert (gfc_state_stack
);
1399 p
->construct
= gfc_state_stack
->tail
;
1401 gfc_state_stack
= p
;
1405 /* Pop the current state. */
1409 gfc_state_stack
= gfc_state_stack
->previous
;
1413 /* Try to find the given state in the state stack. */
1416 gfc_find_state (gfc_compile_state state
)
1420 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1421 if (p
->state
== state
)
1424 return (p
== NULL
) ? false : true;
1428 /* Starts a new level in the statement list. */
1431 new_level (gfc_code
*q
)
1435 p
= q
->block
= gfc_get_code (EXEC_NOP
);
1437 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1443 /* Add the current new_st code structure and adds it to the current
1444 program unit. As a side-effect, it zeroes the new_st. */
1447 add_statement (void)
1451 p
= XCNEW (gfc_code
);
1454 p
->loc
= gfc_current_locus
;
1456 if (gfc_state_stack
->head
== NULL
)
1457 gfc_state_stack
->head
= p
;
1459 gfc_state_stack
->tail
->next
= p
;
1461 while (p
->next
!= NULL
)
1464 gfc_state_stack
->tail
= p
;
1466 gfc_clear_new_st ();
1472 /* Frees everything associated with the current statement. */
1475 undo_new_statement (void)
1477 gfc_free_statements (new_st
.block
);
1478 gfc_free_statements (new_st
.next
);
1479 gfc_free_statement (&new_st
);
1480 gfc_clear_new_st ();
1484 /* If the current statement has a statement label, make sure that it
1485 is allowed to, or should have one. */
1488 check_statement_label (gfc_statement st
)
1492 if (gfc_statement_label
== NULL
)
1494 if (st
== ST_FORMAT
)
1495 gfc_error ("FORMAT statement at %L does not have a statement label",
1502 case ST_END_PROGRAM
:
1503 case ST_END_FUNCTION
:
1504 case ST_END_SUBROUTINE
:
1508 case ST_END_CRITICAL
:
1510 case ST_END_ASSOCIATE
:
1513 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
1514 type
= ST_LABEL_DO_TARGET
;
1516 type
= ST_LABEL_TARGET
;
1520 type
= ST_LABEL_FORMAT
;
1523 /* Statement labels are not restricted from appearing on a
1524 particular line. However, there are plenty of situations
1525 where the resulting label can't be referenced. */
1528 type
= ST_LABEL_BAD_TARGET
;
1532 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1534 new_st
.here
= gfc_statement_label
;
1538 /* Figures out what the enclosing program unit is. This will be a
1539 function, subroutine, program, block data or module. */
1542 gfc_enclosing_unit (gfc_compile_state
* result
)
1546 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1547 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1548 || p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
1549 || p
->state
== COMP_BLOCK_DATA
|| p
->state
== COMP_PROGRAM
)
1558 *result
= COMP_PROGRAM
;
1563 /* Translate a statement enum to a string. */
1566 gfc_ascii_statement (gfc_statement st
)
1572 case ST_ARITHMETIC_IF
:
1573 p
= _("arithmetic IF");
1582 p
= _("attribute declaration");
1618 p
= _("data declaration");
1626 case ST_DERIVED_DECL
:
1627 p
= _("derived type declaration");
1641 case ST_END_ASSOCIATE
:
1642 p
= "END ASSOCIATE";
1647 case ST_END_BLOCK_DATA
:
1648 p
= "END BLOCK DATA";
1650 case ST_END_CRITICAL
:
1662 case ST_END_FUNCTION
:
1668 case ST_END_INTERFACE
:
1669 p
= "END INTERFACE";
1674 case ST_END_SUBMODULE
:
1675 p
= "END SUBMODULE";
1677 case ST_END_PROGRAM
:
1683 case ST_END_SUBROUTINE
:
1684 p
= "END SUBROUTINE";
1695 case ST_EQUIVALENCE
:
1707 case ST_FORALL_BLOCK
: /* Fall through */
1729 case ST_IMPLICIT_NONE
:
1730 p
= "IMPLICIT NONE";
1732 case ST_IMPLIED_ENDDO
:
1733 p
= _("implied END DO");
1765 case ST_MODULE_PROC
:
1766 p
= "MODULE PROCEDURE";
1798 case ST_SYNC_IMAGES
:
1801 case ST_SYNC_MEMORY
:
1816 case ST_WHERE_BLOCK
: /* Fall through */
1827 p
= _("assignment");
1829 case ST_POINTER_ASSIGNMENT
:
1830 p
= _("pointer assignment");
1832 case ST_SELECT_CASE
:
1835 case ST_SELECT_TYPE
:
1850 case ST_STATEMENT_FUNCTION
:
1851 p
= "STATEMENT FUNCTION";
1853 case ST_LABEL_ASSIGNMENT
:
1854 p
= "LABEL ASSIGNMENT";
1857 p
= "ENUM DEFINITION";
1860 p
= "ENUMERATOR DEFINITION";
1865 case ST_OACC_PARALLEL_LOOP
:
1866 p
= "!$ACC PARALLEL LOOP";
1868 case ST_OACC_END_PARALLEL_LOOP
:
1869 p
= "!$ACC END PARALLEL LOOP";
1871 case ST_OACC_PARALLEL
:
1872 p
= "!$ACC PARALLEL";
1874 case ST_OACC_END_PARALLEL
:
1875 p
= "!$ACC END PARALLEL";
1877 case ST_OACC_KERNELS
:
1878 p
= "!$ACC KERNELS";
1880 case ST_OACC_END_KERNELS
:
1881 p
= "!$ACC END KERNELS";
1883 case ST_OACC_KERNELS_LOOP
:
1884 p
= "!$ACC KERNELS LOOP";
1886 case ST_OACC_END_KERNELS_LOOP
:
1887 p
= "!$ACC END KERNELS LOOP";
1892 case ST_OACC_END_DATA
:
1893 p
= "!$ACC END DATA";
1895 case ST_OACC_HOST_DATA
:
1896 p
= "!$ACC HOST_DATA";
1898 case ST_OACC_END_HOST_DATA
:
1899 p
= "!$ACC END HOST_DATA";
1904 case ST_OACC_END_LOOP
:
1905 p
= "!$ACC END LOOP";
1907 case ST_OACC_DECLARE
:
1908 p
= "!$ACC DECLARE";
1910 case ST_OACC_UPDATE
:
1919 case ST_OACC_ENTER_DATA
:
1920 p
= "!$ACC ENTER DATA";
1922 case ST_OACC_EXIT_DATA
:
1923 p
= "!$ACC EXIT DATA";
1925 case ST_OACC_ROUTINE
:
1926 p
= "!$ACC ROUTINE";
1931 case ST_OMP_BARRIER
:
1932 p
= "!$OMP BARRIER";
1937 case ST_OMP_CANCELLATION_POINT
:
1938 p
= "!$OMP CANCELLATION POINT";
1940 case ST_OMP_CRITICAL
:
1941 p
= "!$OMP CRITICAL";
1943 case ST_OMP_DECLARE_REDUCTION
:
1944 p
= "!$OMP DECLARE REDUCTION";
1946 case ST_OMP_DECLARE_SIMD
:
1947 p
= "!$OMP DECLARE SIMD";
1949 case ST_OMP_DECLARE_TARGET
:
1950 p
= "!$OMP DECLARE TARGET";
1952 case ST_OMP_DISTRIBUTE
:
1953 p
= "!$OMP DISTRIBUTE";
1955 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
1956 p
= "!$OMP DISTRIBUTE PARALLEL DO";
1958 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
1959 p
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
1961 case ST_OMP_DISTRIBUTE_SIMD
:
1962 p
= "!$OMP DISTRIBUTE SIMD";
1967 case ST_OMP_DO_SIMD
:
1968 p
= "!$OMP DO SIMD";
1970 case ST_OMP_END_ATOMIC
:
1971 p
= "!$OMP END ATOMIC";
1973 case ST_OMP_END_CRITICAL
:
1974 p
= "!$OMP END CRITICAL";
1976 case ST_OMP_END_DISTRIBUTE
:
1977 p
= "!$OMP END DISTRIBUTE";
1979 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO
:
1980 p
= "!$OMP END DISTRIBUTE PARALLEL DO";
1982 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
:
1983 p
= "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
1985 case ST_OMP_END_DISTRIBUTE_SIMD
:
1986 p
= "!$OMP END DISTRIBUTE SIMD";
1991 case ST_OMP_END_DO_SIMD
:
1992 p
= "!$OMP END DO SIMD";
1994 case ST_OMP_END_SIMD
:
1995 p
= "!$OMP END SIMD";
1997 case ST_OMP_END_MASTER
:
1998 p
= "!$OMP END MASTER";
2000 case ST_OMP_END_ORDERED
:
2001 p
= "!$OMP END ORDERED";
2003 case ST_OMP_END_PARALLEL
:
2004 p
= "!$OMP END PARALLEL";
2006 case ST_OMP_END_PARALLEL_DO
:
2007 p
= "!$OMP END PARALLEL DO";
2009 case ST_OMP_END_PARALLEL_DO_SIMD
:
2010 p
= "!$OMP END PARALLEL DO SIMD";
2012 case ST_OMP_END_PARALLEL_SECTIONS
:
2013 p
= "!$OMP END PARALLEL SECTIONS";
2015 case ST_OMP_END_PARALLEL_WORKSHARE
:
2016 p
= "!$OMP END PARALLEL WORKSHARE";
2018 case ST_OMP_END_SECTIONS
:
2019 p
= "!$OMP END SECTIONS";
2021 case ST_OMP_END_SINGLE
:
2022 p
= "!$OMP END SINGLE";
2024 case ST_OMP_END_TASK
:
2025 p
= "!$OMP END TASK";
2027 case ST_OMP_END_TARGET
:
2028 p
= "!$OMP END TARGET";
2030 case ST_OMP_END_TARGET_DATA
:
2031 p
= "!$OMP END TARGET DATA";
2033 case ST_OMP_END_TARGET_TEAMS
:
2034 p
= "!$OMP END TARGET TEAMS";
2036 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
:
2037 p
= "!$OMP END TARGET TEAMS DISTRIBUTE";
2039 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2040 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2042 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2043 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2045 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2046 p
= "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2048 case ST_OMP_END_TASKGROUP
:
2049 p
= "!$OMP END TASKGROUP";
2051 case ST_OMP_END_TEAMS
:
2052 p
= "!$OMP END TEAMS";
2054 case ST_OMP_END_TEAMS_DISTRIBUTE
:
2055 p
= "!$OMP END TEAMS DISTRIBUTE";
2057 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2058 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2060 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2061 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2063 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
:
2064 p
= "!$OMP END TEAMS DISTRIBUTE SIMD";
2066 case ST_OMP_END_WORKSHARE
:
2067 p
= "!$OMP END WORKSHARE";
2075 case ST_OMP_ORDERED
:
2076 p
= "!$OMP ORDERED";
2078 case ST_OMP_PARALLEL
:
2079 p
= "!$OMP PARALLEL";
2081 case ST_OMP_PARALLEL_DO
:
2082 p
= "!$OMP PARALLEL DO";
2084 case ST_OMP_PARALLEL_DO_SIMD
:
2085 p
= "!$OMP PARALLEL DO SIMD";
2087 case ST_OMP_PARALLEL_SECTIONS
:
2088 p
= "!$OMP PARALLEL SECTIONS";
2090 case ST_OMP_PARALLEL_WORKSHARE
:
2091 p
= "!$OMP PARALLEL WORKSHARE";
2093 case ST_OMP_SECTIONS
:
2094 p
= "!$OMP SECTIONS";
2096 case ST_OMP_SECTION
:
2097 p
= "!$OMP SECTION";
2108 case ST_OMP_TARGET_DATA
:
2109 p
= "!$OMP TARGET DATA";
2111 case ST_OMP_TARGET_TEAMS
:
2112 p
= "!$OMP TARGET TEAMS";
2114 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
2115 p
= "!$OMP TARGET TEAMS DISTRIBUTE";
2117 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2118 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2120 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2121 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2123 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2124 p
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2126 case ST_OMP_TARGET_UPDATE
:
2127 p
= "!$OMP TARGET UPDATE";
2132 case ST_OMP_TASKGROUP
:
2133 p
= "!$OMP TASKGROUP";
2135 case ST_OMP_TASKWAIT
:
2136 p
= "!$OMP TASKWAIT";
2138 case ST_OMP_TASKYIELD
:
2139 p
= "!$OMP TASKYIELD";
2144 case ST_OMP_TEAMS_DISTRIBUTE
:
2145 p
= "!$OMP TEAMS DISTRIBUTE";
2147 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2148 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2150 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2151 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2153 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
2154 p
= "!$OMP TEAMS DISTRIBUTE SIMD";
2156 case ST_OMP_THREADPRIVATE
:
2157 p
= "!$OMP THREADPRIVATE";
2159 case ST_OMP_WORKSHARE
:
2160 p
= "!$OMP WORKSHARE";
2163 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2170 /* Create a symbol for the main program and assign it to ns->proc_name. */
2173 main_program_symbol (gfc_namespace
*ns
, const char *name
)
2175 gfc_symbol
*main_program
;
2176 symbol_attribute attr
;
2178 gfc_get_symbol (name
, ns
, &main_program
);
2179 gfc_clear_attr (&attr
);
2180 attr
.flavor
= FL_PROGRAM
;
2181 attr
.proc
= PROC_UNKNOWN
;
2182 attr
.subroutine
= 1;
2183 attr
.access
= ACCESS_PUBLIC
;
2184 attr
.is_main_program
= 1;
2185 main_program
->attr
= attr
;
2186 main_program
->declared_at
= gfc_current_locus
;
2187 ns
->proc_name
= main_program
;
2188 gfc_commit_symbols ();
2192 /* Do whatever is necessary to accept the last statement. */
2195 accept_statement (gfc_statement st
)
2199 case ST_IMPLICIT_NONE
:
2207 gfc_current_ns
->proc_name
= gfc_new_block
;
2210 /* If the statement is the end of a block, lay down a special code
2211 that allows a branch to the end of the block from within the
2212 construct. IF and SELECT are treated differently from DO
2213 (where EXEC_NOP is added inside the loop) for two
2215 1. END DO has a meaning in the sense that after a GOTO to
2216 it, the loop counter must be increased.
2217 2. IF blocks and SELECT blocks can consist of multiple
2218 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
2219 Putting the label before the END IF would make the jump
2220 from, say, the ELSE IF block to the END IF illegal. */
2224 case ST_END_CRITICAL
:
2225 if (gfc_statement_label
!= NULL
)
2227 new_st
.op
= EXEC_END_NESTED_BLOCK
;
2232 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
2233 one parallel block. Thus, we add the special code to the nested block
2234 itself, instead of the parent one. */
2236 case ST_END_ASSOCIATE
:
2237 if (gfc_statement_label
!= NULL
)
2239 new_st
.op
= EXEC_END_BLOCK
;
2244 /* The end-of-program unit statements do not get the special
2245 marker and require a statement of some sort if they are a
2248 case ST_END_PROGRAM
:
2249 case ST_END_FUNCTION
:
2250 case ST_END_SUBROUTINE
:
2251 if (gfc_statement_label
!= NULL
)
2253 new_st
.op
= EXEC_RETURN
;
2258 new_st
.op
= EXEC_END_PROCEDURE
;
2274 gfc_commit_symbols ();
2275 gfc_warning_check ();
2276 gfc_clear_new_st ();
2280 /* Undo anything tentative that has been built for the current
2284 reject_statement (void)
2286 /* Revert to the previous charlen chain. */
2287 gfc_free_charlen (gfc_current_ns
->cl_list
, gfc_current_ns
->old_cl_list
);
2288 gfc_current_ns
->cl_list
= gfc_current_ns
->old_cl_list
;
2290 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
2291 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
2293 gfc_reject_data (gfc_current_ns
);
2295 gfc_new_block
= NULL
;
2296 gfc_undo_symbols ();
2297 gfc_clear_warning ();
2298 undo_new_statement ();
2302 /* Generic complaint about an out of order statement. We also do
2303 whatever is necessary to clean up. */
2306 unexpected_statement (gfc_statement st
)
2308 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
2310 reject_statement ();
2314 /* Given the next statement seen by the matcher, make sure that it is
2315 in proper order with the last. This subroutine is initialized by
2316 calling it with an argument of ST_NONE. If there is a problem, we
2317 issue an error and return false. Otherwise we return true.
2319 Individual parsers need to verify that the statements seen are
2320 valid before calling here, i.e., ENTRY statements are not allowed in
2321 INTERFACE blocks. The following diagram is taken from the standard:
2323 +---------------------------------------+
2324 | program subroutine function module |
2325 +---------------------------------------+
2327 +---------------------------------------+
2329 +---------------------------------------+
2331 | +-----------+------------------+
2332 | | parameter | implicit |
2333 | +-----------+------------------+
2334 | format | | derived type |
2335 | entry | parameter | interface |
2336 | | data | specification |
2337 | | | statement func |
2338 | +-----------+------------------+
2339 | | data | executable |
2340 +--------+-----------+------------------+
2342 +---------------------------------------+
2343 | internal module/subprogram |
2344 +---------------------------------------+
2346 +---------------------------------------+
2355 ORDER_IMPLICIT_NONE
,
2363 enum state_order state
;
2364 gfc_statement last_statement
;
2370 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
2376 p
->state
= ORDER_START
;
2380 if (p
->state
> ORDER_USE
)
2382 p
->state
= ORDER_USE
;
2386 if (p
->state
> ORDER_IMPORT
)
2388 p
->state
= ORDER_IMPORT
;
2391 case ST_IMPLICIT_NONE
:
2392 if (p
->state
> ORDER_IMPLICIT
)
2395 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2396 statement disqualifies a USE but not an IMPLICIT NONE.
2397 Duplicate IMPLICIT NONEs are caught when the implicit types
2400 p
->state
= ORDER_IMPLICIT_NONE
;
2404 if (p
->state
> ORDER_IMPLICIT
)
2406 p
->state
= ORDER_IMPLICIT
;
2411 if (p
->state
< ORDER_IMPLICIT_NONE
)
2412 p
->state
= ORDER_IMPLICIT_NONE
;
2416 if (p
->state
>= ORDER_EXEC
)
2418 if (p
->state
< ORDER_IMPLICIT
)
2419 p
->state
= ORDER_IMPLICIT
;
2423 if (p
->state
< ORDER_SPEC
)
2424 p
->state
= ORDER_SPEC
;
2429 case ST_DERIVED_DECL
:
2430 case ST_OACC_DECLARE
:
2432 if (p
->state
>= ORDER_EXEC
)
2434 if (p
->state
< ORDER_SPEC
)
2435 p
->state
= ORDER_SPEC
;
2440 if (p
->state
< ORDER_EXEC
)
2441 p
->state
= ORDER_EXEC
;
2448 /* All is well, record the statement in case we need it next time. */
2449 p
->where
= gfc_current_locus
;
2450 p
->last_statement
= st
;
2455 gfc_error ("%s statement at %C cannot follow %s statement at %L",
2456 gfc_ascii_statement (st
),
2457 gfc_ascii_statement (p
->last_statement
), &p
->where
);
2463 /* Handle an unexpected end of file. This is a show-stopper... */
2465 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
2468 unexpected_eof (void)
2472 gfc_error ("Unexpected end of file in %qs", gfc_source_file
);
2474 /* Memory cleanup. Move to "second to last". */
2475 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
2478 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
2481 longjmp (eof_buf
, 1);
2485 /* Parse the CONTAINS section of a derived type definition. */
2487 gfc_access gfc_typebound_default_access
;
2490 parse_derived_contains (void)
2493 bool seen_private
= false;
2494 bool seen_comps
= false;
2495 bool error_flag
= false;
2498 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2499 gcc_assert (gfc_current_block ());
2501 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
2503 if (gfc_current_block ()->attr
.sequence
)
2504 gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
2505 " section at %C", gfc_current_block ()->name
);
2506 if (gfc_current_block ()->attr
.is_bind_c
)
2507 gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
2508 " section at %C", gfc_current_block ()->name
);
2510 accept_statement (ST_CONTAINS
);
2511 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
2513 gfc_typebound_default_access
= ACCESS_PUBLIC
;
2519 st
= next_statement ();
2527 gfc_error ("Components in TYPE at %C must precede CONTAINS");
2531 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
2534 accept_statement (ST_PROCEDURE
);
2539 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
2542 accept_statement (ST_GENERIC
);
2547 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
2551 accept_statement (ST_FINAL
);
2559 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
2560 "at %C with empty CONTAINS section")))
2563 /* ST_END_TYPE is accepted by parse_derived after return. */
2567 if (!gfc_find_state (COMP_MODULE
))
2569 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2576 gfc_error ("PRIVATE statement at %C must precede procedure"
2583 gfc_error ("Duplicate PRIVATE statement at %C");
2587 accept_statement (ST_PRIVATE
);
2588 gfc_typebound_default_access
= ACCESS_PRIVATE
;
2589 seen_private
= true;
2593 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2597 gfc_error ("Already inside a CONTAINS block at %C");
2601 unexpected_statement (st
);
2609 reject_statement ();
2613 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2619 /* Parse a derived type. */
2622 parse_derived (void)
2624 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
2628 gfc_component
*c
, *lock_comp
= NULL
;
2630 accept_statement (ST_DERIVED_DECL
);
2631 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
2633 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
2640 while (compiling_type
)
2642 st
= next_statement ();
2650 accept_statement (st
);
2655 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
2662 if (!seen_component
)
2663 gfc_notify_std (GFC_STD_F2003
, "Derived type "
2664 "definition at %C without components");
2666 accept_statement (ST_END_TYPE
);
2670 if (!gfc_find_state (COMP_MODULE
))
2672 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2679 gfc_error ("PRIVATE statement at %C must precede "
2680 "structure components");
2685 gfc_error ("Duplicate PRIVATE statement at %C");
2687 s
.sym
->component_access
= ACCESS_PRIVATE
;
2689 accept_statement (ST_PRIVATE
);
2696 gfc_error ("SEQUENCE statement at %C must precede "
2697 "structure components");
2701 if (gfc_current_block ()->attr
.sequence
)
2702 gfc_warning (0, "SEQUENCE attribute at %C already specified in "
2707 gfc_error ("Duplicate SEQUENCE statement at %C");
2711 gfc_add_sequence (&gfc_current_block ()->attr
,
2712 gfc_current_block ()->name
, NULL
);
2716 gfc_notify_std (GFC_STD_F2003
,
2717 "CONTAINS block in derived type"
2718 " definition at %C");
2720 accept_statement (ST_CONTAINS
);
2721 parse_derived_contains ();
2725 unexpected_statement (st
);
2730 /* need to verify that all fields of the derived type are
2731 * interoperable with C if the type is declared to be bind(c)
2733 sym
= gfc_current_block ();
2734 for (c
= sym
->components
; c
; c
= c
->next
)
2736 bool coarray
, lock_type
, allocatable
, pointer
;
2737 coarray
= lock_type
= allocatable
= pointer
= false;
2739 /* Look for allocatable components. */
2740 if (c
->attr
.allocatable
2741 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2742 && CLASS_DATA (c
)->attr
.allocatable
)
2743 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
2744 && c
->ts
.u
.derived
->attr
.alloc_comp
))
2747 sym
->attr
.alloc_comp
= 1;
2750 /* Look for pointer components. */
2752 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2753 && CLASS_DATA (c
)->attr
.class_pointer
)
2754 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
2757 sym
->attr
.pointer_comp
= 1;
2760 /* Look for procedure pointer components. */
2761 if (c
->attr
.proc_pointer
2762 || (c
->ts
.type
== BT_DERIVED
2763 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
2764 sym
->attr
.proc_pointer_comp
= 1;
2766 /* Looking for coarray components. */
2767 if (c
->attr
.codimension
2768 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2769 && CLASS_DATA (c
)->attr
.codimension
))
2772 sym
->attr
.coarray_comp
= 1;
2775 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
2776 && !c
->attr
.pointer
)
2779 sym
->attr
.coarray_comp
= 1;
2782 /* Looking for lock_type components. */
2783 if ((c
->ts
.type
== BT_DERIVED
2784 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2785 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2786 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2787 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2788 == INTMOD_ISO_FORTRAN_ENV
2789 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2790 == ISOFORTRAN_LOCK_TYPE
)
2791 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
2792 && !allocatable
&& !pointer
))
2796 sym
->attr
.lock_comp
= 1;
2799 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2800 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2801 unless there are nondirect [allocatable or pointer] components
2802 involved (cf. 1.3.33.1 and 1.3.33.3). */
2804 if (pointer
&& !coarray
&& lock_type
)
2805 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2806 "codimension or be a subcomponent of a coarray, "
2807 "which is not possible as the component has the "
2808 "pointer attribute", c
->name
, &c
->loc
);
2809 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
2810 && c
->ts
.u
.derived
->attr
.lock_comp
)
2811 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2812 "of type LOCK_TYPE, which must have a codimension or be a "
2813 "subcomponent of a coarray", c
->name
, &c
->loc
);
2815 if (lock_type
&& allocatable
&& !coarray
)
2816 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
2817 "a codimension", c
->name
, &c
->loc
);
2818 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
2819 && c
->ts
.u
.derived
->attr
.lock_comp
)
2820 gfc_error ("Allocatable component %s at %L must have a codimension as "
2821 "it has a noncoarray subcomponent of type LOCK_TYPE",
2824 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
2825 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2826 "subcomponent of type LOCK_TYPE must have a codimension or "
2827 "be a subcomponent of a coarray. (Variables of type %s may "
2828 "not have a codimension as already a coarray "
2829 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
2831 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
2832 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2833 "subcomponent of type LOCK_TYPE must have a codimension or "
2834 "be a subcomponent of a coarray. (Variables of type %s may "
2835 "not have a codimension as %s at %L has a codimension or a "
2836 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
2837 sym
->name
, c
->name
, &c
->loc
);
2839 /* Look for private components. */
2840 if (sym
->component_access
== ACCESS_PRIVATE
2841 || c
->attr
.access
== ACCESS_PRIVATE
2842 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
2843 sym
->attr
.private_comp
= 1;
2846 if (!seen_component
)
2847 sym
->attr
.zero_comp
= 1;
2853 /* Parse an ENUM. */
2861 int seen_enumerator
= 0;
2863 push_state (&s
, COMP_ENUM
, gfc_new_block
);
2867 while (compiling_enum
)
2869 st
= next_statement ();
2877 seen_enumerator
= 1;
2878 accept_statement (st
);
2883 if (!seen_enumerator
)
2884 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2885 accept_statement (st
);
2889 gfc_free_enum_history ();
2890 unexpected_statement (st
);
2898 /* Parse an interface. We must be able to deal with the possibility
2899 of recursive interfaces. The parse_spec() subroutine is mutually
2900 recursive with parse_interface(). */
2902 static gfc_statement
parse_spec (gfc_statement
);
2905 parse_interface (void)
2907 gfc_compile_state new_state
= COMP_NONE
, current_state
;
2908 gfc_symbol
*prog_unit
, *sym
;
2909 gfc_interface_info save
;
2910 gfc_state_data s1
, s2
;
2913 accept_statement (ST_INTERFACE
);
2915 current_interface
.ns
= gfc_current_ns
;
2916 save
= current_interface
;
2918 sym
= (current_interface
.type
== INTERFACE_GENERIC
2919 || current_interface
.type
== INTERFACE_USER_OP
)
2920 ? gfc_new_block
: NULL
;
2922 push_state (&s1
, COMP_INTERFACE
, sym
);
2923 current_state
= COMP_NONE
;
2926 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
2928 st
= next_statement ();
2936 if (st
== ST_SUBROUTINE
)
2937 new_state
= COMP_SUBROUTINE
;
2938 else if (st
== ST_FUNCTION
)
2939 new_state
= COMP_FUNCTION
;
2940 if (gfc_new_block
->attr
.pointer
)
2942 gfc_new_block
->attr
.pointer
= 0;
2943 gfc_new_block
->attr
.proc_pointer
= 1;
2945 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
2946 gfc_new_block
->formal
, NULL
))
2948 reject_statement ();
2949 gfc_free_namespace (gfc_current_ns
);
2952 /* F2008 C1210 forbids the IMPORT statement in module procedure
2953 interface bodies and the flag is set to import symbols. */
2954 if (gfc_new_block
->attr
.module_procedure
)
2955 gfc_current_ns
->has_import_set
= 1;
2959 case ST_MODULE_PROC
: /* The module procedure matcher makes
2960 sure the context is correct. */
2961 accept_statement (st
);
2962 gfc_free_namespace (gfc_current_ns
);
2965 case ST_END_INTERFACE
:
2966 gfc_free_namespace (gfc_current_ns
);
2967 gfc_current_ns
= current_interface
.ns
;
2971 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2972 gfc_ascii_statement (st
));
2973 reject_statement ();
2974 gfc_free_namespace (gfc_current_ns
);
2979 /* Make sure that the generic name has the right attribute. */
2980 if (current_interface
.type
== INTERFACE_GENERIC
2981 && current_state
== COMP_NONE
)
2983 if (new_state
== COMP_FUNCTION
&& sym
)
2984 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
2985 else if (new_state
== COMP_SUBROUTINE
&& sym
)
2986 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
2988 current_state
= new_state
;
2991 if (current_interface
.type
== INTERFACE_ABSTRACT
)
2993 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
2994 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
2995 gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
2996 "cannot be the same as an intrinsic type",
2997 gfc_new_block
->name
);
3000 push_state (&s2
, new_state
, gfc_new_block
);
3001 accept_statement (st
);
3002 prog_unit
= gfc_new_block
;
3003 prog_unit
->formal_ns
= gfc_current_ns
;
3004 if (prog_unit
== prog_unit
->formal_ns
->proc_name
3005 && prog_unit
->ns
!= prog_unit
->formal_ns
)
3009 /* Read data declaration statements. */
3010 st
= parse_spec (ST_NONE
);
3012 /* Since the interface block does not permit an IMPLICIT statement,
3013 the default type for the function or the result must be taken
3014 from the formal namespace. */
3015 if (new_state
== COMP_FUNCTION
)
3017 if (prog_unit
->result
== prog_unit
3018 && prog_unit
->ts
.type
== BT_UNKNOWN
)
3019 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
3020 else if (prog_unit
->result
!= prog_unit
3021 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
3022 gfc_set_default_type (prog_unit
->result
, 1,
3023 prog_unit
->formal_ns
);
3026 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
3028 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
3029 gfc_ascii_statement (st
));
3030 reject_statement ();
3034 /* Add EXTERNAL attribute to function or subroutine. */
3035 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
3036 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
3038 current_interface
= save
;
3039 gfc_add_interface (prog_unit
);
3042 if (current_interface
.ns
3043 && current_interface
.ns
->proc_name
3044 && strcmp (current_interface
.ns
->proc_name
->name
,
3045 prog_unit
->name
) == 0)
3046 gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
3047 "enclosing procedure", prog_unit
->name
,
3048 ¤t_interface
.ns
->proc_name
->declared_at
);
3057 /* Associate function characteristics by going back to the function
3058 declaration and rematching the prefix. */
3061 match_deferred_characteristics (gfc_typespec
* ts
)
3064 match m
= MATCH_ERROR
;
3065 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3067 loc
= gfc_current_locus
;
3069 gfc_current_locus
= gfc_current_block ()->declared_at
;
3072 gfc_buffer_error (true);
3073 m
= gfc_match_prefix (ts
);
3074 gfc_buffer_error (false);
3076 if (ts
->type
== BT_DERIVED
)
3084 /* Only permit one go at the characteristic association. */
3088 /* Set the function locus correctly. If we have not found the
3089 function name, there is an error. */
3091 && gfc_match ("function% %n", name
) == MATCH_YES
3092 && strcmp (name
, gfc_current_block ()->name
) == 0)
3094 gfc_current_block ()->declared_at
= gfc_current_locus
;
3095 gfc_commit_symbols ();
3100 gfc_undo_symbols ();
3103 gfc_current_locus
=loc
;
3108 /* Check specification-expressions in the function result of the currently
3109 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
3110 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
3111 scope are not yet parsed so this has to be delayed up to parse_spec. */
3114 check_function_result_typed (void)
3116 gfc_typespec
* ts
= &gfc_current_ns
->proc_name
->result
->ts
;
3118 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
3119 gcc_assert (ts
->type
!= BT_UNKNOWN
);
3121 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
3122 /* TODO: Extend when KIND type parameters are implemented. */
3123 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
)
3124 gfc_expr_check_typed (ts
->u
.cl
->length
, gfc_current_ns
, true);
3128 /* Parse a set of specification statements. Returns the statement
3129 that doesn't fit. */
3131 static gfc_statement
3132 parse_spec (gfc_statement st
)
3135 bool function_result_typed
= false;
3136 bool bad_characteristic
= false;
3139 verify_st_order (&ss
, ST_NONE
, false);
3141 st
= next_statement ();
3143 /* If we are not inside a function or don't have a result specified so far,
3144 do nothing special about it. */
3145 if (gfc_current_state () != COMP_FUNCTION
)
3146 function_result_typed
= true;
3149 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
3152 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
3153 function_result_typed
= true;
3158 /* If we're inside a BLOCK construct, some statements are disallowed.
3159 Check this here. Attribute declaration statements like INTENT, OPTIONAL
3160 or VALUE are also disallowed, but they don't have a particular ST_*
3161 key so we have to check for them individually in their matcher routine. */
3162 if (gfc_current_state () == COMP_BLOCK
)
3166 case ST_IMPLICIT_NONE
:
3169 case ST_EQUIVALENCE
:
3170 case ST_STATEMENT_FUNCTION
:
3171 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
3172 gfc_ascii_statement (st
));
3173 reject_statement ();
3179 else if (gfc_current_state () == COMP_BLOCK_DATA
)
3180 /* Fortran 2008, C1116. */
3187 case ST_END_BLOCK_DATA
:
3189 case ST_EQUIVALENCE
:
3192 case ST_IMPLICIT_NONE
:
3193 case ST_DERIVED_DECL
:
3201 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
3202 gfc_ascii_statement (st
));
3203 reject_statement ();
3207 /* If we find a statement that can not be followed by an IMPLICIT statement
3208 (and thus we can expect to see none any further), type the function result
3209 if it has not yet been typed. Be careful not to give the END statement
3210 to verify_st_order! */
3211 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
3213 bool verify_now
= false;
3215 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
3220 verify_st_order (&dummyss
, ST_NONE
, false);
3221 verify_st_order (&dummyss
, st
, false);
3223 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
3229 check_function_result_typed ();
3230 function_result_typed
= true;
3239 case ST_IMPLICIT_NONE
:
3241 if (!function_result_typed
)
3243 check_function_result_typed ();
3244 function_result_typed
= true;
3250 case ST_DATA
: /* Not allowed in interfaces */
3251 if (gfc_current_state () == COMP_INTERFACE
)
3261 case ST_DERIVED_DECL
:
3264 if (!verify_st_order (&ss
, st
, false))
3266 reject_statement ();
3267 st
= next_statement ();
3277 case ST_DERIVED_DECL
:
3283 if (gfc_current_state () != COMP_MODULE
)
3285 gfc_error ("%s statement must appear in a MODULE",
3286 gfc_ascii_statement (st
));
3287 reject_statement ();
3291 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
3293 gfc_error ("%s statement at %C follows another accessibility "
3294 "specification", gfc_ascii_statement (st
));
3295 reject_statement ();
3299 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
3300 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3304 case ST_STATEMENT_FUNCTION
:
3305 if (gfc_current_state () == COMP_MODULE
3306 || gfc_current_state () == COMP_SUBMODULE
)
3308 unexpected_statement (st
);
3316 accept_statement (st
);
3317 st
= next_statement ();
3321 accept_statement (st
);
3323 st
= next_statement ();
3326 case ST_GET_FCN_CHARACTERISTICS
:
3327 /* This statement triggers the association of a function's result
3329 ts
= &gfc_current_block ()->result
->ts
;
3330 if (match_deferred_characteristics (ts
) != MATCH_YES
)
3331 bad_characteristic
= true;
3333 st
= next_statement ();
3336 case ST_OACC_DECLARE
:
3337 if (!verify_st_order(&ss
, st
, false))
3339 reject_statement ();
3340 st
= next_statement ();
3343 if (gfc_state_stack
->ext
.oacc_declare_clauses
== NULL
)
3344 gfc_state_stack
->ext
.oacc_declare_clauses
= new_st
.ext
.omp_clauses
;
3345 accept_statement (st
);
3346 st
= next_statement ();
3353 /* If match_deferred_characteristics failed, then there is an error. */
3354 if (bad_characteristic
)
3356 ts
= &gfc_current_block ()->result
->ts
;
3357 if (ts
->type
!= BT_DERIVED
)
3358 gfc_error ("Bad kind expression for function %qs at %L",
3359 gfc_current_block ()->name
,
3360 &gfc_current_block ()->declared_at
);
3362 gfc_error ("The type for function %qs at %L is not accessible",
3363 gfc_current_block ()->name
,
3364 &gfc_current_block ()->declared_at
);
3366 gfc_current_block ()->ts
.kind
= 0;
3367 /* Keep the derived type; if it's bad, it will be discovered later. */
3368 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
3369 ts
->type
= BT_UNKNOWN
;
3376 /* Parse a WHERE block, (not a simple WHERE statement). */
3379 parse_where_block (void)
3381 int seen_empty_else
;
3386 accept_statement (ST_WHERE_BLOCK
);
3387 top
= gfc_state_stack
->tail
;
3389 push_state (&s
, COMP_WHERE
, gfc_new_block
);
3391 d
= add_statement ();
3392 d
->expr1
= top
->expr1
;
3398 seen_empty_else
= 0;
3402 st
= next_statement ();
3408 case ST_WHERE_BLOCK
:
3409 parse_where_block ();
3414 accept_statement (st
);
3418 if (seen_empty_else
)
3420 gfc_error ("ELSEWHERE statement at %C follows previous "
3421 "unmasked ELSEWHERE");
3422 reject_statement ();
3426 if (new_st
.expr1
== NULL
)
3427 seen_empty_else
= 1;
3429 d
= new_level (gfc_state_stack
->head
);
3431 d
->expr1
= new_st
.expr1
;
3433 accept_statement (st
);
3438 accept_statement (st
);
3442 gfc_error ("Unexpected %s statement in WHERE block at %C",
3443 gfc_ascii_statement (st
));
3444 reject_statement ();
3448 while (st
!= ST_END_WHERE
);
3454 /* Parse a FORALL block (not a simple FORALL statement). */
3457 parse_forall_block (void)
3463 accept_statement (ST_FORALL_BLOCK
);
3464 top
= gfc_state_stack
->tail
;
3466 push_state (&s
, COMP_FORALL
, gfc_new_block
);
3468 d
= add_statement ();
3469 d
->op
= EXEC_FORALL
;
3474 st
= next_statement ();
3479 case ST_POINTER_ASSIGNMENT
:
3482 accept_statement (st
);
3485 case ST_WHERE_BLOCK
:
3486 parse_where_block ();
3489 case ST_FORALL_BLOCK
:
3490 parse_forall_block ();
3494 accept_statement (st
);
3501 gfc_error ("Unexpected %s statement in FORALL block at %C",
3502 gfc_ascii_statement (st
));
3504 reject_statement ();
3508 while (st
!= ST_END_FORALL
);
3514 static gfc_statement
parse_executable (gfc_statement
);
3516 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
3519 parse_if_block (void)
3528 accept_statement (ST_IF_BLOCK
);
3530 top
= gfc_state_stack
->tail
;
3531 push_state (&s
, COMP_IF
, gfc_new_block
);
3533 new_st
.op
= EXEC_IF
;
3534 d
= add_statement ();
3536 d
->expr1
= top
->expr1
;
3542 st
= parse_executable (ST_NONE
);
3552 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
3553 "statement at %L", &else_locus
);
3555 reject_statement ();
3559 d
= new_level (gfc_state_stack
->head
);
3561 d
->expr1
= new_st
.expr1
;
3563 accept_statement (st
);
3570 gfc_error ("Duplicate ELSE statements at %L and %C",
3572 reject_statement ();
3577 else_locus
= gfc_current_locus
;
3579 d
= new_level (gfc_state_stack
->head
);
3582 accept_statement (st
);
3590 unexpected_statement (st
);
3594 while (st
!= ST_ENDIF
);
3597 accept_statement (st
);
3601 /* Parse a SELECT block. */
3604 parse_select_block (void)
3610 accept_statement (ST_SELECT_CASE
);
3612 cp
= gfc_state_stack
->tail
;
3613 push_state (&s
, COMP_SELECT
, gfc_new_block
);
3615 /* Make sure that the next statement is a CASE or END SELECT. */
3618 st
= next_statement ();
3621 if (st
== ST_END_SELECT
)
3623 /* Empty SELECT CASE is OK. */
3624 accept_statement (st
);
3631 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
3634 reject_statement ();
3637 /* At this point, we're got a nonempty select block. */
3638 cp
= new_level (cp
);
3641 accept_statement (st
);
3645 st
= parse_executable (ST_NONE
);
3652 cp
= new_level (gfc_state_stack
->head
);
3654 gfc_clear_new_st ();
3656 accept_statement (st
);
3662 /* Can't have an executable statement because of
3663 parse_executable(). */
3665 unexpected_statement (st
);
3669 while (st
!= ST_END_SELECT
);
3672 accept_statement (st
);
3676 /* Pop the current selector from the SELECT TYPE stack. */
3679 select_type_pop (void)
3681 gfc_select_type_stack
*old
= select_type_stack
;
3682 select_type_stack
= old
->prev
;
3687 /* Parse a SELECT TYPE construct (F03:R821). */
3690 parse_select_type_block (void)
3696 accept_statement (ST_SELECT_TYPE
);
3698 cp
= gfc_state_stack
->tail
;
3699 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
3701 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
3705 st
= next_statement ();
3708 if (st
== ST_END_SELECT
)
3709 /* Empty SELECT CASE is OK. */
3711 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
3714 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
3715 "following SELECT TYPE at %C");
3717 reject_statement ();
3720 /* At this point, we're got a nonempty select block. */
3721 cp
= new_level (cp
);
3724 accept_statement (st
);
3728 st
= parse_executable (ST_NONE
);
3736 cp
= new_level (gfc_state_stack
->head
);
3738 gfc_clear_new_st ();
3740 accept_statement (st
);
3746 /* Can't have an executable statement because of
3747 parse_executable(). */
3749 unexpected_statement (st
);
3753 while (st
!= ST_END_SELECT
);
3757 accept_statement (st
);
3758 gfc_current_ns
= gfc_current_ns
->parent
;
3763 /* Given a symbol, make sure it is not an iteration variable for a DO
3764 statement. This subroutine is called when the symbol is seen in a
3765 context that causes it to become redefined. If the symbol is an
3766 iterator, we generate an error message and return nonzero. */
3769 gfc_check_do_variable (gfc_symtree
*st
)
3773 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
3774 if (s
->do_variable
== st
)
3776 gfc_error_now ("Variable %qs at %C cannot be redefined inside "
3777 "loop beginning at %L", st
->name
, &s
->head
->loc
);
3785 /* Checks to see if the current statement label closes an enddo.
3786 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3787 an error) if it incorrectly closes an ENDDO. */
3790 check_do_closure (void)
3794 if (gfc_statement_label
== NULL
)
3797 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
3798 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
3802 return 0; /* No loops to close */
3804 if (p
->ext
.end_do_label
== gfc_statement_label
)
3806 if (p
== gfc_state_stack
)
3809 gfc_error ("End of nonblock DO statement at %C is within another block");
3813 /* At this point, the label doesn't terminate the innermost loop.
3814 Make sure it doesn't terminate another one. */
3815 for (; p
; p
= p
->previous
)
3816 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
3817 && p
->ext
.end_do_label
== gfc_statement_label
)
3819 gfc_error ("End of nonblock DO statement at %C is interwoven "
3820 "with another DO loop");
3828 /* Parse a series of contained program units. */
3830 static void parse_progunit (gfc_statement
);
3833 /* Parse a CRITICAL block. */
3836 parse_critical_block (void)
3839 gfc_state_data s
, *sd
;
3842 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
3843 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
3844 gfc_error_now (is_oacc (sd
)
3845 ? "CRITICAL block inside of OpenACC region at %C"
3846 : "CRITICAL block inside of OpenMP region at %C");
3848 s
.ext
.end_do_label
= new_st
.label1
;
3850 accept_statement (ST_CRITICAL
);
3851 top
= gfc_state_stack
->tail
;
3853 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
3855 d
= add_statement ();
3856 d
->op
= EXEC_CRITICAL
;
3861 st
= parse_executable (ST_NONE
);
3869 case ST_END_CRITICAL
:
3870 if (s
.ext
.end_do_label
!= NULL
3871 && s
.ext
.end_do_label
!= gfc_statement_label
)
3872 gfc_error_now ("Statement label in END CRITICAL at %C does not "
3873 "match CRITICAL label");
3875 if (gfc_statement_label
!= NULL
)
3877 new_st
.op
= EXEC_NOP
;
3883 unexpected_statement (st
);
3887 while (st
!= ST_END_CRITICAL
);
3890 accept_statement (st
);
3894 /* Set up the local namespace for a BLOCK construct. */
3897 gfc_build_block_ns (gfc_namespace
*parent_ns
)
3899 gfc_namespace
* my_ns
;
3900 static int numblock
= 1;
3902 my_ns
= gfc_get_namespace (parent_ns
, 1);
3903 my_ns
->construct_entities
= 1;
3905 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3906 code generation (so it must not be NULL).
3907 We set its recursive argument if our container procedure is recursive, so
3908 that local variables are accordingly placed on the stack when it
3909 will be necessary. */
3911 my_ns
->proc_name
= gfc_new_block
;
3915 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
3917 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
3918 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
3919 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
3920 my_ns
->proc_name
->name
, NULL
);
3922 gfc_commit_symbol (my_ns
->proc_name
);
3925 if (parent_ns
->proc_name
)
3926 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
3932 /* Parse a BLOCK construct. */
3935 parse_block_construct (void)
3937 gfc_namespace
* my_ns
;
3938 gfc_namespace
* my_parent
;
3941 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
3943 my_ns
= gfc_build_block_ns (gfc_current_ns
);
3945 new_st
.op
= EXEC_BLOCK
;
3946 new_st
.ext
.block
.ns
= my_ns
;
3947 new_st
.ext
.block
.assoc
= NULL
;
3948 accept_statement (ST_BLOCK
);
3950 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
3951 gfc_current_ns
= my_ns
;
3952 my_parent
= my_ns
->parent
;
3954 parse_progunit (ST_NONE
);
3956 /* Don't depend on the value of gfc_current_ns; it might have been
3957 reset if the block had errors and was cleaned up. */
3958 gfc_current_ns
= my_parent
;
3964 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
3965 behind the scenes with compiler-generated variables. */
3968 parse_associate (void)
3970 gfc_namespace
* my_ns
;
3973 gfc_association_list
* a
;
3975 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
3977 my_ns
= gfc_build_block_ns (gfc_current_ns
);
3979 new_st
.op
= EXEC_BLOCK
;
3980 new_st
.ext
.block
.ns
= my_ns
;
3981 gcc_assert (new_st
.ext
.block
.assoc
);
3983 /* Add all associate-names as BLOCK variables. Creating them is enough
3984 for now, they'll get their values during trans-* phase. */
3985 gfc_current_ns
= my_ns
;
3986 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
3990 gfc_array_ref
*array_ref
;
3992 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
3996 sym
->attr
.flavor
= FL_VARIABLE
;
3998 sym
->declared_at
= a
->where
;
3999 gfc_set_sym_referenced (sym
);
4001 /* Initialize the typespec. It is not available in all cases,
4002 however, as it may only be set on the target during resolution.
4003 Still, sometimes it helps to have it right now -- especially
4004 for parsing component references on the associate-name
4005 in case of association to a derived-type. */
4006 sym
->ts
= a
->target
->ts
;
4008 /* Check if the target expression is array valued. This can not always
4009 be done by looking at target.rank, because that might not have been
4010 set yet. Therefore traverse the chain of refs, looking for the last
4011 array ref and evaluate that. */
4013 for (ref
= a
->target
->ref
; ref
; ref
= ref
->next
)
4014 if (ref
->type
== REF_ARRAY
)
4015 array_ref
= &ref
->u
.ar
;
4016 if (array_ref
|| a
->target
->rank
)
4022 /* Count the dimension, that have a non-scalar extend. */
4023 for (dim
= 0; dim
< array_ref
->dimen
; ++dim
)
4024 if (array_ref
->dimen_type
[dim
] != DIMEN_ELEMENT
4025 && !(array_ref
->dimen_type
[dim
] == DIMEN_UNKNOWN
4026 && array_ref
->end
[dim
] == NULL
4027 && array_ref
->start
[dim
] != NULL
))
4031 rank
= a
->target
->rank
;
4032 /* When the rank is greater than zero then sym will be an array. */
4033 if (sym
->ts
.type
== BT_CLASS
)
4035 if ((!CLASS_DATA (sym
)->as
&& rank
!= 0)
4036 || (CLASS_DATA (sym
)->as
4037 && CLASS_DATA (sym
)->as
->rank
!= rank
))
4039 /* Don't just (re-)set the attr and as in the sym.ts,
4040 because this modifies the target's attr and as. Copy the
4041 data and do a build_class_symbol. */
4042 symbol_attribute attr
= CLASS_DATA (a
->target
)->attr
;
4043 int corank
= gfc_get_corank (a
->target
);
4048 as
= gfc_get_array_spec ();
4049 as
->type
= AS_DEFERRED
;
4051 as
->corank
= corank
;
4052 attr
.dimension
= rank
? 1 : 0;
4053 attr
.codimension
= corank
? 1 : 0;
4058 attr
.dimension
= attr
.codimension
= 0;
4061 type
= CLASS_DATA (sym
)->ts
;
4062 if (!gfc_build_class_symbol (&type
,
4066 sym
->ts
.type
= BT_CLASS
;
4067 sym
->attr
.class_ok
= 1;
4070 sym
->attr
.class_ok
= 1;
4072 else if ((!sym
->as
&& rank
!= 0)
4073 || (sym
->as
&& sym
->as
->rank
!= rank
))
4075 as
= gfc_get_array_spec ();
4076 as
->type
= AS_DEFERRED
;
4078 as
->corank
= gfc_get_corank (a
->target
);
4080 sym
->attr
.dimension
= 1;
4082 sym
->attr
.codimension
= 1;
4087 accept_statement (ST_ASSOCIATE
);
4088 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
4091 st
= parse_executable (ST_NONE
);
4098 accept_statement (st
);
4099 my_ns
->code
= gfc_state_stack
->head
;
4103 unexpected_statement (st
);
4107 gfc_current_ns
= gfc_current_ns
->parent
;
4112 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
4113 handled inside of parse_executable(), because they aren't really
4117 parse_do_block (void)
4126 s
.ext
.end_do_label
= new_st
.label1
;
4128 if (new_st
.ext
.iterator
!= NULL
)
4129 stree
= new_st
.ext
.iterator
->var
->symtree
;
4133 accept_statement (ST_DO
);
4135 top
= gfc_state_stack
->tail
;
4136 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
4139 s
.do_variable
= stree
;
4141 top
->block
= new_level (top
);
4142 top
->block
->op
= EXEC_DO
;
4145 st
= parse_executable (ST_NONE
);
4153 if (s
.ext
.end_do_label
!= NULL
4154 && s
.ext
.end_do_label
!= gfc_statement_label
)
4155 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
4158 if (gfc_statement_label
!= NULL
)
4160 new_st
.op
= EXEC_NOP
;
4165 case ST_IMPLIED_ENDDO
:
4166 /* If the do-stmt of this DO construct has a do-construct-name,
4167 the corresponding end-do must be an end-do-stmt (with a matching
4168 name, but in that case we must have seen ST_ENDDO first).
4169 We only complain about this in pedantic mode. */
4170 if (gfc_current_block () != NULL
)
4171 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
4172 &gfc_current_block()->declared_at
);
4177 unexpected_statement (st
);
4182 accept_statement (st
);
4186 /* Parse the statements of OpenMP do/parallel do. */
4188 static gfc_statement
4189 parse_omp_do (gfc_statement omp_st
)
4195 accept_statement (omp_st
);
4197 cp
= gfc_state_stack
->tail
;
4198 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4199 np
= new_level (cp
);
4205 st
= next_statement ();
4208 else if (st
== ST_DO
)
4211 unexpected_statement (st
);
4215 if (gfc_statement_label
!= NULL
4216 && gfc_state_stack
->previous
!= NULL
4217 && gfc_state_stack
->previous
->state
== COMP_DO
4218 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4226 there should be no !$OMP END DO. */
4228 return ST_IMPLIED_ENDDO
;
4231 check_do_closure ();
4234 st
= next_statement ();
4235 gfc_statement omp_end_st
= ST_OMP_END_DO
;
4238 case ST_OMP_DISTRIBUTE
: omp_end_st
= ST_OMP_END_DISTRIBUTE
; break;
4239 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4240 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4242 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4243 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4245 case ST_OMP_DISTRIBUTE_SIMD
:
4246 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4248 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
4249 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
4250 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
4251 case ST_OMP_PARALLEL_DO_SIMD
:
4252 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
4254 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
4255 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4256 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4258 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4259 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4261 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4262 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4264 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4265 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4267 case ST_OMP_TEAMS_DISTRIBUTE
:
4268 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4270 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4271 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4273 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4274 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4276 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4277 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4279 default: gcc_unreachable ();
4281 if (st
== omp_end_st
)
4283 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
4284 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4286 gcc_assert (new_st
.op
== EXEC_NOP
);
4287 gfc_clear_new_st ();
4288 gfc_commit_symbols ();
4289 gfc_warning_check ();
4290 st
= next_statement ();
4296 /* Parse the statements of OpenMP atomic directive. */
4298 static gfc_statement
4299 parse_omp_atomic (void)
4306 accept_statement (ST_OMP_ATOMIC
);
4308 cp
= gfc_state_stack
->tail
;
4309 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4310 np
= new_level (cp
);
4313 count
= 1 + ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4314 == GFC_OMP_ATOMIC_CAPTURE
);
4318 st
= next_statement ();
4321 else if (st
== ST_ASSIGNMENT
)
4323 accept_statement (st
);
4327 unexpected_statement (st
);
4332 st
= next_statement ();
4333 if (st
== ST_OMP_END_ATOMIC
)
4335 gfc_clear_new_st ();
4336 gfc_commit_symbols ();
4337 gfc_warning_check ();
4338 st
= next_statement ();
4340 else if ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4341 == GFC_OMP_ATOMIC_CAPTURE
)
4342 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
4347 /* Parse the statements of an OpenACC structured block. */
4350 parse_oacc_structured_block (gfc_statement acc_st
)
4352 gfc_statement st
, acc_end_st
;
4354 gfc_state_data s
, *sd
;
4356 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4357 if (sd
->state
== COMP_CRITICAL
)
4358 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4360 accept_statement (acc_st
);
4362 cp
= gfc_state_stack
->tail
;
4363 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4364 np
= new_level (cp
);
4369 case ST_OACC_PARALLEL
:
4370 acc_end_st
= ST_OACC_END_PARALLEL
;
4372 case ST_OACC_KERNELS
:
4373 acc_end_st
= ST_OACC_END_KERNELS
;
4376 acc_end_st
= ST_OACC_END_DATA
;
4378 case ST_OACC_HOST_DATA
:
4379 acc_end_st
= ST_OACC_END_HOST_DATA
;
4387 st
= parse_executable (ST_NONE
);
4390 else if (st
!= acc_end_st
)
4392 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
4393 reject_statement ();
4396 while (st
!= acc_end_st
);
4398 gcc_assert (new_st
.op
== EXEC_NOP
);
4400 gfc_clear_new_st ();
4401 gfc_commit_symbols ();
4402 gfc_warning_check ();
4406 /* Parse the statements of OpenACC loop/parallel loop/kernels loop. */
4408 static gfc_statement
4409 parse_oacc_loop (gfc_statement acc_st
)
4413 gfc_state_data s
, *sd
;
4415 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4416 if (sd
->state
== COMP_CRITICAL
)
4417 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4419 accept_statement (acc_st
);
4421 cp
= gfc_state_stack
->tail
;
4422 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4423 np
= new_level (cp
);
4429 st
= next_statement ();
4432 else if (st
== ST_DO
)
4436 gfc_error ("Expected DO loop at %C");
4437 reject_statement ();
4442 if (gfc_statement_label
!= NULL
4443 && gfc_state_stack
->previous
!= NULL
4444 && gfc_state_stack
->previous
->state
== COMP_DO
4445 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4448 return ST_IMPLIED_ENDDO
;
4451 check_do_closure ();
4454 st
= next_statement ();
4455 if (st
== ST_OACC_END_LOOP
)
4456 gfc_warning (0, "Redundant !$ACC END LOOP at %C");
4457 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
4458 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
4459 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
4461 gcc_assert (new_st
.op
== EXEC_NOP
);
4462 gfc_clear_new_st ();
4463 gfc_commit_symbols ();
4464 gfc_warning_check ();
4465 st
= next_statement ();
4471 /* Parse the statements of an OpenMP structured block. */
4474 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
4476 gfc_statement st
, omp_end_st
;
4480 accept_statement (omp_st
);
4482 cp
= gfc_state_stack
->tail
;
4483 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4484 np
= new_level (cp
);
4490 case ST_OMP_PARALLEL
:
4491 omp_end_st
= ST_OMP_END_PARALLEL
;
4493 case ST_OMP_PARALLEL_SECTIONS
:
4494 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
4496 case ST_OMP_SECTIONS
:
4497 omp_end_st
= ST_OMP_END_SECTIONS
;
4499 case ST_OMP_ORDERED
:
4500 omp_end_st
= ST_OMP_END_ORDERED
;
4502 case ST_OMP_CRITICAL
:
4503 omp_end_st
= ST_OMP_END_CRITICAL
;
4506 omp_end_st
= ST_OMP_END_MASTER
;
4509 omp_end_st
= ST_OMP_END_SINGLE
;
4512 omp_end_st
= ST_OMP_END_TARGET
;
4514 case ST_OMP_TARGET_DATA
:
4515 omp_end_st
= ST_OMP_END_TARGET_DATA
;
4517 case ST_OMP_TARGET_TEAMS
:
4518 omp_end_st
= ST_OMP_END_TARGET_TEAMS
;
4520 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4521 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4523 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4524 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4526 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4527 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4529 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4530 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4533 omp_end_st
= ST_OMP_END_TASK
;
4535 case ST_OMP_TASKGROUP
:
4536 omp_end_st
= ST_OMP_END_TASKGROUP
;
4539 omp_end_st
= ST_OMP_END_TEAMS
;
4541 case ST_OMP_TEAMS_DISTRIBUTE
:
4542 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4544 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4545 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4547 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4548 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4550 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4551 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4553 case ST_OMP_DISTRIBUTE
:
4554 omp_end_st
= ST_OMP_END_DISTRIBUTE
;
4556 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4557 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4559 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4560 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4562 case ST_OMP_DISTRIBUTE_SIMD
:
4563 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4565 case ST_OMP_WORKSHARE
:
4566 omp_end_st
= ST_OMP_END_WORKSHARE
;
4568 case ST_OMP_PARALLEL_WORKSHARE
:
4569 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
4577 if (workshare_stmts_only
)
4579 /* Inside of !$omp workshare, only
4582 where statements and constructs
4583 forall statements and constructs
4587 are allowed. For !$omp critical these
4588 restrictions apply recursively. */
4591 st
= next_statement ();
4602 accept_statement (st
);
4605 case ST_WHERE_BLOCK
:
4606 parse_where_block ();
4609 case ST_FORALL_BLOCK
:
4610 parse_forall_block ();
4613 case ST_OMP_PARALLEL
:
4614 case ST_OMP_PARALLEL_SECTIONS
:
4615 parse_omp_structured_block (st
, false);
4618 case ST_OMP_PARALLEL_WORKSHARE
:
4619 case ST_OMP_CRITICAL
:
4620 parse_omp_structured_block (st
, true);
4623 case ST_OMP_PARALLEL_DO
:
4624 case ST_OMP_PARALLEL_DO_SIMD
:
4625 st
= parse_omp_do (st
);
4629 st
= parse_omp_atomic ();
4640 st
= next_statement ();
4644 st
= parse_executable (ST_NONE
);
4647 else if (st
== ST_OMP_SECTION
4648 && (omp_st
== ST_OMP_SECTIONS
4649 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
4651 np
= new_level (np
);
4655 else if (st
!= omp_end_st
)
4656 unexpected_statement (st
);
4658 while (st
!= omp_end_st
);
4662 case EXEC_OMP_END_NOWAIT
:
4663 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4665 case EXEC_OMP_CRITICAL
:
4666 if (((cp
->ext
.omp_name
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
4667 || (new_st
.ext
.omp_name
!= NULL
4668 && strcmp (cp
->ext
.omp_name
, new_st
.ext
.omp_name
) != 0))
4669 gfc_error ("Name after !$omp critical and !$omp end critical does "
4671 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
4673 case EXEC_OMP_END_SINGLE
:
4674 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
4675 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
4676 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
4677 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
4685 gfc_clear_new_st ();
4686 gfc_commit_symbols ();
4687 gfc_warning_check ();
4692 /* Accept a series of executable statements. We return the first
4693 statement that doesn't fit to the caller. Any block statements are
4694 passed on to the correct handler, which usually passes the buck
4697 static gfc_statement
4698 parse_executable (gfc_statement st
)
4703 st
= next_statement ();
4707 close_flag
= check_do_closure ();
4712 case ST_END_PROGRAM
:
4715 case ST_END_FUNCTION
:
4720 case ST_END_SUBROUTINE
:
4725 case ST_SELECT_CASE
:
4726 gfc_error ("%s statement at %C cannot terminate a non-block "
4727 "DO loop", gfc_ascii_statement (st
));
4740 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
4741 "first executable statement");
4747 accept_statement (st
);
4748 if (close_flag
== 1)
4749 return ST_IMPLIED_ENDDO
;
4753 parse_block_construct ();
4764 case ST_SELECT_CASE
:
4765 parse_select_block ();
4768 case ST_SELECT_TYPE
:
4769 parse_select_type_block();
4774 if (check_do_closure () == 1)
4775 return ST_IMPLIED_ENDDO
;
4779 parse_critical_block ();
4782 case ST_WHERE_BLOCK
:
4783 parse_where_block ();
4786 case ST_FORALL_BLOCK
:
4787 parse_forall_block ();
4790 case ST_OACC_PARALLEL_LOOP
:
4791 case ST_OACC_KERNELS_LOOP
:
4793 st
= parse_oacc_loop (st
);
4794 if (st
== ST_IMPLIED_ENDDO
)
4798 case ST_OACC_PARALLEL
:
4799 case ST_OACC_KERNELS
:
4801 case ST_OACC_HOST_DATA
:
4802 parse_oacc_structured_block (st
);
4805 case ST_OMP_PARALLEL
:
4806 case ST_OMP_PARALLEL_SECTIONS
:
4807 case ST_OMP_SECTIONS
:
4808 case ST_OMP_ORDERED
:
4809 case ST_OMP_CRITICAL
:
4813 case ST_OMP_TARGET_DATA
:
4814 case ST_OMP_TARGET_TEAMS
:
4817 case ST_OMP_TASKGROUP
:
4818 parse_omp_structured_block (st
, false);
4821 case ST_OMP_WORKSHARE
:
4822 case ST_OMP_PARALLEL_WORKSHARE
:
4823 parse_omp_structured_block (st
, true);
4826 case ST_OMP_DISTRIBUTE
:
4827 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4828 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4829 case ST_OMP_DISTRIBUTE_SIMD
:
4831 case ST_OMP_DO_SIMD
:
4832 case ST_OMP_PARALLEL_DO
:
4833 case ST_OMP_PARALLEL_DO_SIMD
:
4835 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4836 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4837 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4838 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4839 case ST_OMP_TEAMS_DISTRIBUTE
:
4840 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4841 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4842 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4843 st
= parse_omp_do (st
);
4844 if (st
== ST_IMPLIED_ENDDO
)
4849 st
= parse_omp_atomic ();
4856 st
= next_statement ();
4861 /* Fix the symbols for sibling functions. These are incorrectly added to
4862 the child namespace as the parser didn't know about this procedure. */
4865 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
4869 gfc_symbol
*old_sym
;
4871 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
4873 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
4875 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
4876 goto fixup_contained
;
4878 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
4879 && sym
->attr
.generic
&& sym
->attr
.function
)
4880 ||(sym
->attr
.flavor
== FL_DERIVED
4881 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
4882 goto fixup_contained
;
4884 old_sym
= st
->n
.sym
;
4885 if (old_sym
->ns
== ns
4886 && !old_sym
->attr
.contained
4888 /* By 14.6.1.3, host association should be excluded
4889 for the following. */
4890 && !(old_sym
->attr
.external
4891 || (old_sym
->ts
.type
!= BT_UNKNOWN
4892 && !old_sym
->attr
.implicit_type
)
4893 || old_sym
->attr
.flavor
== FL_PARAMETER
4894 || old_sym
->attr
.use_assoc
4895 || old_sym
->attr
.in_common
4896 || old_sym
->attr
.in_equivalence
4897 || old_sym
->attr
.data
4898 || old_sym
->attr
.dummy
4899 || old_sym
->attr
.result
4900 || old_sym
->attr
.dimension
4901 || old_sym
->attr
.allocatable
4902 || old_sym
->attr
.intrinsic
4903 || old_sym
->attr
.generic
4904 || old_sym
->attr
.flavor
== FL_NAMELIST
4905 || old_sym
->attr
.flavor
== FL_LABEL
4906 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
4908 /* Replace it with the symbol from the parent namespace. */
4912 gfc_release_symbol (old_sym
);
4916 /* Do the same for any contained procedures. */
4917 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
4922 parse_contained (int module
)
4924 gfc_namespace
*ns
, *parent_ns
, *tmp
;
4925 gfc_state_data s1
, s2
;
4929 int contains_statements
= 0;
4932 push_state (&s1
, COMP_CONTAINS
, NULL
);
4933 parent_ns
= gfc_current_ns
;
4937 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
4939 gfc_current_ns
->sibling
= parent_ns
->contained
;
4940 parent_ns
->contained
= gfc_current_ns
;
4943 /* Process the next available statement. We come here if we got an error
4944 and rejected the last statement. */
4945 st
= next_statement ();
4954 contains_statements
= 1;
4955 accept_statement (st
);
4958 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
4961 /* For internal procedures, create/update the symbol in the
4962 parent namespace. */
4966 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
4967 gfc_error ("Contained procedure %qs at %C is already "
4968 "ambiguous", gfc_new_block
->name
);
4971 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
4973 &gfc_new_block
->declared_at
))
4975 if (st
== ST_FUNCTION
)
4976 gfc_add_function (&sym
->attr
, sym
->name
,
4977 &gfc_new_block
->declared_at
);
4979 gfc_add_subroutine (&sym
->attr
, sym
->name
,
4980 &gfc_new_block
->declared_at
);
4984 gfc_commit_symbols ();
4987 sym
= gfc_new_block
;
4989 /* Mark this as a contained function, so it isn't replaced
4990 by other module functions. */
4991 sym
->attr
.contained
= 1;
4993 /* Set implicit_pure so that it can be reset if any of the
4994 tests for purity fail. This is used for some optimisation
4995 during translation. */
4996 if (!sym
->attr
.pure
)
4997 sym
->attr
.implicit_pure
= 1;
4999 parse_progunit (ST_NONE
);
5001 /* Fix up any sibling functions that refer to this one. */
5002 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
5003 /* Or refer to any of its alternate entry points. */
5004 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
5005 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
5007 gfc_current_ns
->code
= s2
.head
;
5008 gfc_current_ns
= parent_ns
;
5013 /* These statements are associated with the end of the host unit. */
5014 case ST_END_FUNCTION
:
5016 case ST_END_SUBMODULE
:
5017 case ST_END_PROGRAM
:
5018 case ST_END_SUBROUTINE
:
5019 accept_statement (st
);
5020 gfc_current_ns
->code
= s1
.head
;
5024 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
5025 gfc_ascii_statement (st
));
5026 reject_statement ();
5032 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
5033 && st
!= ST_END_MODULE
&& st
!= ST_END_SUBMODULE
5034 && st
!= ST_END_PROGRAM
);
5036 /* The first namespace in the list is guaranteed to not have
5037 anything (worthwhile) in it. */
5038 tmp
= gfc_current_ns
;
5039 gfc_current_ns
= parent_ns
;
5040 if (seen_error
&& tmp
->refs
> 1)
5041 gfc_free_namespace (tmp
);
5043 ns
= gfc_current_ns
->contained
;
5044 gfc_current_ns
->contained
= ns
->sibling
;
5045 gfc_free_namespace (ns
);
5048 if (!contains_statements
)
5049 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
5050 "FUNCTION or SUBROUTINE statement at %C");
5054 /* The result variable in a MODULE PROCEDURE needs to be created and
5055 its characteristics copied from the interface since it is neither
5056 declared in the procedure declaration nor in the specification
5060 get_modproc_result (void)
5063 if (gfc_state_stack
->previous
5064 && gfc_state_stack
->previous
->state
== COMP_CONTAINS
5065 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
5067 proc
= gfc_current_ns
->proc_name
? gfc_current_ns
->proc_name
: NULL
;
5069 && proc
->attr
.function
5070 && proc
->ts
.interface
5071 && proc
->ts
.interface
->result
5072 && proc
->ts
.interface
->result
!= proc
->ts
.interface
)
5074 gfc_copy_dummy_sym (&proc
->result
, proc
->ts
.interface
->result
, 1);
5075 gfc_set_sym_referenced (proc
->result
);
5076 proc
->result
->attr
.if_source
= IFSRC_DECL
;
5077 gfc_commit_symbol (proc
->result
);
5083 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
5086 parse_progunit (gfc_statement st
)
5092 && gfc_new_block
->abr_modproc_decl
5093 && gfc_new_block
->attr
.function
)
5094 get_modproc_result ();
5096 st
= parse_spec (st
);
5103 /* This is not allowed within BLOCK! */
5104 if (gfc_current_state () != COMP_BLOCK
)
5109 accept_statement (st
);
5116 if (gfc_current_state () == COMP_FUNCTION
)
5117 gfc_check_function_type (gfc_current_ns
);
5122 st
= parse_executable (st
);
5130 /* This is not allowed within BLOCK! */
5131 if (gfc_current_state () != COMP_BLOCK
)
5136 accept_statement (st
);
5143 unexpected_statement (st
);
5144 reject_statement ();
5145 st
= next_statement ();
5151 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
5152 if (p
->state
== COMP_CONTAINS
)
5155 if (gfc_find_state (COMP_MODULE
) == true
5156 || gfc_find_state (COMP_SUBMODULE
) == true)
5161 gfc_error ("CONTAINS statement at %C is already in a contained "
5163 reject_statement ();
5164 st
= next_statement ();
5168 parse_contained (0);
5171 gfc_current_ns
->code
= gfc_state_stack
->head
;
5172 if (gfc_state_stack
->state
== COMP_PROGRAM
5173 || gfc_state_stack
->state
== COMP_MODULE
5174 || gfc_state_stack
->state
== COMP_SUBROUTINE
5175 || gfc_state_stack
->state
== COMP_FUNCTION
5176 || gfc_state_stack
->state
== COMP_BLOCK
)
5177 gfc_current_ns
->oacc_declare_clauses
5178 = gfc_state_stack
->ext
.oacc_declare_clauses
;
5182 /* Come here to complain about a global symbol already in use as
5186 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
5191 where
= &gfc_current_locus
;
5201 case GSYM_SUBROUTINE
:
5202 name
= "SUBROUTINE";
5207 case GSYM_BLOCK_DATA
:
5208 name
= "BLOCK DATA";
5214 gfc_internal_error ("gfc_global_used(): Bad type");
5218 if (sym
->binding_label
)
5219 gfc_error ("Global binding name %qs at %L is already being used as a %s "
5220 "at %L", sym
->binding_label
, where
, name
, &sym
->where
);
5222 gfc_error ("Global name %qs at %L is already being used as a %s at %L",
5223 sym
->name
, where
, name
, &sym
->where
);
5227 /* Parse a block data program unit. */
5230 parse_block_data (void)
5233 static locus blank_locus
;
5234 static int blank_block
=0;
5237 gfc_current_ns
->proc_name
= gfc_new_block
;
5238 gfc_current_ns
->is_block_data
= 1;
5240 if (gfc_new_block
== NULL
)
5243 gfc_error ("Blank BLOCK DATA at %C conflicts with "
5244 "prior BLOCK DATA at %L", &blank_locus
);
5248 blank_locus
= gfc_current_locus
;
5253 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5255 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
5256 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5259 s
->type
= GSYM_BLOCK_DATA
;
5260 s
->where
= gfc_new_block
->declared_at
;
5265 st
= parse_spec (ST_NONE
);
5267 while (st
!= ST_END_BLOCK_DATA
)
5269 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
5270 gfc_ascii_statement (st
));
5271 reject_statement ();
5272 st
= next_statement ();
5277 /* Following the association of the ancestor (sub)module symbols, they
5278 must be set host rather than use associated and all must be public.
5279 They are flagged up by 'used_in_submodule' so that they can be set
5280 DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
5281 linker chokes on multiple symbol definitions. */
5284 set_syms_host_assoc (gfc_symbol
*sym
)
5291 if (sym
->attr
.module_procedure
)
5292 sym
->attr
.external
= 0;
5294 /* sym->attr.access = ACCESS_PUBLIC; */
5296 sym
->attr
.use_assoc
= 0;
5297 sym
->attr
.host_assoc
= 1;
5298 sym
->attr
.used_in_submodule
=1;
5300 if (sym
->attr
.flavor
== FL_DERIVED
)
5302 for (c
= sym
->components
; c
; c
= c
->next
)
5303 c
->attr
.access
= ACCESS_PUBLIC
;
5307 /* Parse a module subprogram. */
5316 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5317 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
5318 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5321 s
->type
= GSYM_MODULE
;
5322 s
->where
= gfc_new_block
->declared_at
;
5326 /* Something is nulling the module_list after this point. This is good
5327 since it allows us to 'USE' the parent modules that the submodule
5328 inherits and to set (most) of the symbols as host associated. */
5329 if (gfc_current_state () == COMP_SUBMODULE
)
5332 gfc_traverse_ns (gfc_current_ns
, set_syms_host_assoc
);
5335 st
= parse_spec (ST_NONE
);
5345 parse_contained (1);
5349 case ST_END_SUBMODULE
:
5350 accept_statement (st
);
5354 gfc_error ("Unexpected %s statement in MODULE at %C",
5355 gfc_ascii_statement (st
));
5358 reject_statement ();
5359 st
= next_statement ();
5363 /* Make sure not to free the namespace twice on error. */
5365 s
->ns
= gfc_current_ns
;
5369 /* Add a procedure name to the global symbol table. */
5372 add_global_procedure (bool sub
)
5376 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5377 name is a global identifier. */
5378 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5380 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5383 || (s
->type
!= GSYM_UNKNOWN
5384 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5386 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5387 /* Silence follow-up errors. */
5388 gfc_new_block
->binding_label
= NULL
;
5392 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5393 s
->sym_name
= gfc_new_block
->name
;
5394 s
->where
= gfc_new_block
->declared_at
;
5396 s
->ns
= gfc_current_ns
;
5400 /* Don't add the symbol multiple times. */
5401 if (gfc_new_block
->binding_label
5402 && (!gfc_notification_std (GFC_STD_F2008
)
5403 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
5405 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
);
5408 || (s
->type
!= GSYM_UNKNOWN
5409 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5411 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5412 /* Silence follow-up errors. */
5413 gfc_new_block
->binding_label
= NULL
;
5417 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5418 s
->sym_name
= gfc_new_block
->name
;
5419 s
->binding_label
= gfc_new_block
->binding_label
;
5420 s
->where
= gfc_new_block
->declared_at
;
5422 s
->ns
= gfc_current_ns
;
5428 /* Add a program to the global symbol table. */
5431 add_global_program (void)
5435 if (gfc_new_block
== NULL
)
5437 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5439 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
5440 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5443 s
->type
= GSYM_PROGRAM
;
5444 s
->where
= gfc_new_block
->declared_at
;
5446 s
->ns
= gfc_current_ns
;
5451 /* Resolve all the program units. */
5453 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
5455 gfc_free_dt_list ();
5456 gfc_current_ns
= gfc_global_ns_list
;
5457 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5459 if (gfc_current_ns
->proc_name
5460 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5461 continue; /* Already resolved. */
5463 if (gfc_current_ns
->proc_name
)
5464 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5465 gfc_resolve (gfc_current_ns
);
5466 gfc_current_ns
->derived_types
= gfc_derived_types
;
5467 gfc_derived_types
= NULL
;
5473 clean_up_modules (gfc_gsymbol
*gsym
)
5478 clean_up_modules (gsym
->left
);
5479 clean_up_modules (gsym
->right
);
5481 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
5484 gfc_current_ns
= gsym
->ns
;
5485 gfc_derived_types
= gfc_current_ns
->derived_types
;
5492 /* Translate all the program units. This could be in a different order
5493 to resolution if there are forward references in the file. */
5495 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
5499 gfc_current_ns
= gfc_global_ns_list
;
5500 gfc_get_errors (NULL
, &errors
);
5502 /* We first translate all modules to make sure that later parts
5503 of the program can use the decl. Then we translate the nonmodules. */
5505 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5507 if (!gfc_current_ns
->proc_name
5508 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5511 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5512 gfc_derived_types
= gfc_current_ns
->derived_types
;
5513 gfc_generate_module_code (gfc_current_ns
);
5514 gfc_current_ns
->translated
= 1;
5517 gfc_current_ns
= gfc_global_ns_list
;
5518 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5520 if (gfc_current_ns
->proc_name
5521 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5524 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5525 gfc_derived_types
= gfc_current_ns
->derived_types
;
5526 gfc_generate_code (gfc_current_ns
);
5527 gfc_current_ns
->translated
= 1;
5530 /* Clean up all the namespaces after translation. */
5531 gfc_current_ns
= gfc_global_ns_list
;
5532 for (;gfc_current_ns
;)
5536 if (gfc_current_ns
->proc_name
5537 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5539 gfc_current_ns
= gfc_current_ns
->sibling
;
5543 ns
= gfc_current_ns
->sibling
;
5544 gfc_derived_types
= gfc_current_ns
->derived_types
;
5546 gfc_current_ns
= ns
;
5549 clean_up_modules (gfc_gsym_root
);
5553 /* Top level parser. */
5556 gfc_parse_file (void)
5558 int seen_program
, errors_before
, errors
;
5559 gfc_state_data top
, s
;
5562 gfc_namespace
*next
;
5564 gfc_start_source_files ();
5566 top
.state
= COMP_NONE
;
5568 top
.previous
= NULL
;
5569 top
.head
= top
.tail
= NULL
;
5570 top
.do_variable
= NULL
;
5572 gfc_state_stack
= &top
;
5574 gfc_clear_new_st ();
5576 gfc_statement_label
= NULL
;
5578 if (setjmp (eof_buf
))
5579 return false; /* Come here on unexpected EOF */
5581 /* Prepare the global namespace that will contain the
5583 gfc_global_ns_list
= next
= NULL
;
5588 /* Exit early for empty files. */
5594 st
= next_statement ();
5603 goto duplicate_main
;
5605 prog_locus
= gfc_current_locus
;
5607 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
5608 main_program_symbol(gfc_current_ns
, gfc_new_block
->name
);
5609 accept_statement (st
);
5610 add_global_program ();
5611 parse_progunit (ST_NONE
);
5616 add_global_procedure (true);
5617 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
5618 accept_statement (st
);
5619 parse_progunit (ST_NONE
);
5624 add_global_procedure (false);
5625 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
5626 accept_statement (st
);
5627 parse_progunit (ST_NONE
);
5632 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
5633 accept_statement (st
);
5634 parse_block_data ();
5638 push_state (&s
, COMP_MODULE
, gfc_new_block
);
5639 accept_statement (st
);
5641 gfc_get_errors (NULL
, &errors_before
);
5646 push_state (&s
, COMP_SUBMODULE
, gfc_new_block
);
5647 accept_statement (st
);
5649 gfc_get_errors (NULL
, &errors_before
);
5653 /* Anything else starts a nameless main program block. */
5656 goto duplicate_main
;
5658 prog_locus
= gfc_current_locus
;
5660 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
5661 main_program_symbol (gfc_current_ns
, "MAIN__");
5662 parse_progunit (st
);
5667 /* Handle the non-program units. */
5668 gfc_current_ns
->code
= s
.head
;
5670 gfc_resolve (gfc_current_ns
);
5672 /* Dump the parse tree if requested. */
5673 if (flag_dump_fortran_original
)
5674 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
5676 gfc_get_errors (NULL
, &errors
);
5677 if (s
.state
== COMP_MODULE
|| s
.state
== COMP_SUBMODULE
)
5679 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
5680 gfc_current_ns
->derived_types
= gfc_derived_types
;
5681 gfc_derived_types
= NULL
;
5687 gfc_generate_code (gfc_current_ns
);
5695 /* The main program and non-contained procedures are put
5696 in the global namespace list, so that they can be processed
5697 later and all their interfaces resolved. */
5698 gfc_current_ns
->code
= s
.head
;
5701 for (; next
->sibling
; next
= next
->sibling
)
5703 next
->sibling
= gfc_current_ns
;
5706 gfc_global_ns_list
= gfc_current_ns
;
5708 next
= gfc_current_ns
;
5715 /* Do the resolution. */
5716 resolve_all_program_units (gfc_global_ns_list
);
5718 /* Do the parse tree dump. */
5720 = flag_dump_fortran_original
? gfc_global_ns_list
: NULL
;
5722 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5723 if (!gfc_current_ns
->proc_name
5724 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5726 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
5727 fputs ("------------------------------------------\n\n", stdout
);
5730 /* Do the translation. */
5731 translate_all_program_units (gfc_global_ns_list
);
5733 gfc_end_source_files ();
5737 /* If we see a duplicate main program, shut down. If the second
5738 instance is an implied main program, i.e. data decls or executable
5739 statements, we're in for lots of errors. */
5740 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
5741 reject_statement ();
5746 /* Return true if this state data represents an OpenACC region. */
5748 is_oacc (gfc_state_data
*sd
)
5750 switch (sd
->construct
->op
)
5752 case EXEC_OACC_PARALLEL_LOOP
:
5753 case EXEC_OACC_PARALLEL
:
5754 case EXEC_OACC_KERNELS_LOOP
:
5755 case EXEC_OACC_KERNELS
:
5756 case EXEC_OACC_DATA
:
5757 case EXEC_OACC_HOST_DATA
:
5758 case EXEC_OACC_LOOP
:
5759 case EXEC_OACC_UPDATE
:
5760 case EXEC_OACC_WAIT
:
5761 case EXEC_OACC_CACHE
:
5762 case EXEC_OACC_ENTER_DATA
:
5763 case EXEC_OACC_EXIT_DATA
: