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_buf old_error_1
;
112 output_buffer old_error
;
114 gfc_push_error (&old_error
, &old_error_1
);
115 gfc_buffer_error (false);
117 gfc_buffer_error (true);
118 gfc_pop_error (&old_error
, &old_error_1
);
119 gfc_commit_symbols ();
120 gfc_warning_check ();
121 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
122 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
123 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
124 last_was_use_stmt
= false;
128 /* Figure out what the next statement is, (mostly) regardless of
129 proper ordering. The do...while(0) is there to prevent if/else
132 #define match(keyword, subr, st) \
134 if (match_word (keyword, subr, &old_locus) == MATCH_YES) \
137 undo_new_statement (); \
141 /* This is a specialist version of decode_statement that is used
142 for the specification statements in a function, whose
143 characteristics are deferred into the specification statements.
144 eg.: INTEGER (king = mykind) foo ()
145 USE mymodule, ONLY mykind.....
146 The KIND parameter needs a return after USE or IMPORT, whereas
147 derived type declarations can occur anywhere, up the executable
148 block. ST_GET_FCN_CHARACTERISTICS is returned when we have run
149 out of the correct kind of specification statements. */
151 decode_specification_statement (void)
157 if (gfc_match_eos () == MATCH_YES
)
160 old_locus
= gfc_current_locus
;
162 if (match_word ("use", gfc_match_use
, &old_locus
) == MATCH_YES
)
164 last_was_use_stmt
= true;
169 undo_new_statement ();
170 if (last_was_use_stmt
)
174 match ("import", gfc_match_import
, ST_IMPORT
);
176 if (gfc_current_block ()->result
->ts
.type
!= BT_DERIVED
)
179 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
180 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
181 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
183 /* General statement matching: Instead of testing every possible
184 statement, we eliminate most possibilities by peeking at the
187 c
= gfc_peek_ascii_char ();
192 match ("abstract% interface", gfc_match_abstract_interface
,
194 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
195 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
199 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
203 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
204 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
208 match ("data", gfc_match_data
, ST_DATA
);
209 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
213 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
214 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
215 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
216 match ("external", gfc_match_external
, ST_ATTR_DECL
);
220 match ("format", gfc_match_format
, ST_FORMAT
);
227 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
228 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
229 match ("interface", gfc_match_interface
, ST_INTERFACE
);
230 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
231 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
238 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
242 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
246 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
247 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
248 if (gfc_match_private (&st
) == MATCH_YES
)
250 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
251 if (gfc_match_public (&st
) == MATCH_YES
)
253 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
260 match ("save", gfc_match_save
, ST_ATTR_DECL
);
264 match ("target", gfc_match_target
, ST_ATTR_DECL
);
265 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
272 match ("value", gfc_match_value
, ST_ATTR_DECL
);
273 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
280 /* This is not a specification statement. See if any of the matchers
281 has stored an error message of some sort. */
285 gfc_buffer_error (false);
286 gfc_current_locus
= old_locus
;
288 return ST_GET_FCN_CHARACTERISTICS
;
292 /* This is the primary 'decode_statement'. */
294 decode_statement (void)
302 gfc_enforce_clean_symbol_state ();
304 gfc_clear_error (); /* Clear any pending errors. */
305 gfc_clear_warning (); /* Clear any pending warnings. */
307 gfc_matching_function
= false;
309 if (gfc_match_eos () == MATCH_YES
)
312 if (gfc_current_state () == COMP_FUNCTION
313 && gfc_current_block ()->result
->ts
.kind
== -1)
314 return decode_specification_statement ();
316 old_locus
= gfc_current_locus
;
318 c
= gfc_peek_ascii_char ();
322 if (match_word ("use", gfc_match_use
, &old_locus
) == MATCH_YES
)
324 last_was_use_stmt
= true;
328 undo_new_statement ();
331 if (last_was_use_stmt
)
334 /* Try matching a data declaration or function declaration. The
335 input "REALFUNCTIONA(N)" can mean several things in different
336 contexts, so it (and its relatives) get special treatment. */
338 if (gfc_current_state () == COMP_NONE
339 || gfc_current_state () == COMP_INTERFACE
340 || gfc_current_state () == COMP_CONTAINS
)
342 gfc_matching_function
= true;
343 m
= gfc_match_function_decl ();
346 else if (m
== MATCH_ERROR
)
350 gfc_current_locus
= old_locus
;
352 gfc_matching_function
= false;
355 /* Match statements whose error messages are meant to be overwritten
356 by something better. */
358 match (NULL
, gfc_match_assignment
, ST_ASSIGNMENT
);
359 match (NULL
, gfc_match_pointer_assignment
, ST_POINTER_ASSIGNMENT
);
360 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
362 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
363 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
365 /* Try to match a subroutine statement, which has the same optional
366 prefixes that functions can have. */
368 if (gfc_match_subroutine () == MATCH_YES
)
369 return ST_SUBROUTINE
;
371 gfc_current_locus
= old_locus
;
373 /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
374 statements, which might begin with a block label. The match functions for
375 these statements are unusual in that their keyword is not seen before
376 the matcher is called. */
378 if (gfc_match_if (&st
) == MATCH_YES
)
381 gfc_current_locus
= old_locus
;
383 if (gfc_match_where (&st
) == MATCH_YES
)
386 gfc_current_locus
= old_locus
;
388 if (gfc_match_forall (&st
) == MATCH_YES
)
391 gfc_current_locus
= old_locus
;
393 match (NULL
, gfc_match_do
, ST_DO
);
394 match (NULL
, gfc_match_block
, ST_BLOCK
);
395 match (NULL
, gfc_match_associate
, ST_ASSOCIATE
);
396 match (NULL
, gfc_match_critical
, ST_CRITICAL
);
397 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
399 gfc_current_ns
= gfc_build_block_ns (gfc_current_ns
);
400 match (NULL
, gfc_match_select_type
, ST_SELECT_TYPE
);
402 gfc_current_ns
= gfc_current_ns
->parent
;
403 gfc_free_namespace (ns
);
405 /* General statement matching: Instead of testing every possible
406 statement, we eliminate most possibilities by peeking at the
412 match ("abstract% interface", gfc_match_abstract_interface
,
414 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
415 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
416 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
417 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
421 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
422 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
423 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
427 match ("call", gfc_match_call
, ST_CALL
);
428 match ("close", gfc_match_close
, ST_CLOSE
);
429 match ("continue", gfc_match_continue
, ST_CONTINUE
);
430 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
431 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
432 match ("case", gfc_match_case
, ST_CASE
);
433 match ("common", gfc_match_common
, ST_COMMON
);
434 match ("contains", gfc_match_eos
, ST_CONTAINS
);
435 match ("class", gfc_match_class_is
, ST_CLASS_IS
);
436 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
440 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
441 match ("data", gfc_match_data
, ST_DATA
);
442 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
446 match ("end file", gfc_match_endfile
, ST_END_FILE
);
447 match ("exit", gfc_match_exit
, ST_EXIT
);
448 match ("else", gfc_match_else
, ST_ELSE
);
449 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
450 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
451 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
);
452 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
454 if (gfc_match_end (&st
) == MATCH_YES
)
457 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
458 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
459 match ("external", gfc_match_external
, ST_ATTR_DECL
);
463 match ("final", gfc_match_final_decl
, ST_FINAL
);
464 match ("flush", gfc_match_flush
, ST_FLUSH
);
465 match ("format", gfc_match_format
, ST_FORMAT
);
469 match ("generic", gfc_match_generic
, ST_GENERIC
);
470 match ("go to", gfc_match_goto
, ST_GOTO
);
474 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
475 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
476 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
477 match ("import", gfc_match_import
, ST_IMPORT
);
478 match ("interface", gfc_match_interface
, ST_INTERFACE
);
479 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
480 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
484 match ("lock", gfc_match_lock
, ST_LOCK
);
488 match ("module% procedure", gfc_match_modproc
, ST_MODULE_PROC
);
489 match ("module", gfc_match_module
, ST_MODULE
);
493 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
494 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
498 match ("open", gfc_match_open
, ST_OPEN
);
499 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
503 match ("print", gfc_match_print
, ST_WRITE
);
504 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
505 match ("pause", gfc_match_pause
, ST_PAUSE
);
506 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
507 if (gfc_match_private (&st
) == MATCH_YES
)
509 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
510 match ("program", gfc_match_program
, ST_PROGRAM
);
511 if (gfc_match_public (&st
) == MATCH_YES
)
513 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
517 match ("read", gfc_match_read
, ST_READ
);
518 match ("return", gfc_match_return
, ST_RETURN
);
519 match ("rewind", gfc_match_rewind
, ST_REWIND
);
523 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
524 match ("stop", gfc_match_stop
, ST_STOP
);
525 match ("save", gfc_match_save
, ST_ATTR_DECL
);
526 match ("sync all", gfc_match_sync_all
, ST_SYNC_ALL
);
527 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
528 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
532 match ("target", gfc_match_target
, ST_ATTR_DECL
);
533 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
534 match ("type is", gfc_match_type_is
, ST_TYPE_IS
);
538 match ("unlock", gfc_match_unlock
, ST_UNLOCK
);
542 match ("value", gfc_match_value
, ST_ATTR_DECL
);
543 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
547 match ("wait", gfc_match_wait
, ST_WAIT
);
548 match ("write", gfc_match_write
, ST_WRITE
);
552 /* All else has failed, so give up. See if any of the matchers has
553 stored an error message of some sort. */
555 if (!gfc_error_check ())
556 gfc_error_now ("Unclassifiable statement at %C");
560 gfc_error_recovery ();
565 /* Like match, but set a flag simd_matched if keyword matched. */
566 #define matchs(keyword, subr, st) \
568 if (match_word_omp_simd (keyword, subr, &old_locus, \
569 &simd_matched) == MATCH_YES) \
572 undo_new_statement (); \
575 /* Like match, but don't match anything if not -fopenmp. */
576 #define matcho(keyword, subr, st) \
580 else if (match_word (keyword, subr, &old_locus) \
584 undo_new_statement (); \
588 decode_oacc_directive (void)
593 gfc_enforce_clean_symbol_state ();
595 gfc_clear_error (); /* Clear any pending errors. */
596 gfc_clear_warning (); /* Clear any pending warnings. */
600 gfc_error_now ("OpenACC directives at %C may not appear in PURE "
602 gfc_error_recovery ();
606 gfc_unset_implicit_pure (NULL
);
608 old_locus
= gfc_current_locus
;
610 /* General OpenACC directive matching: Instead of testing every possible
611 statement, we eliminate most possibilities by peeking at the
614 c
= gfc_peek_ascii_char ();
619 match ("cache", gfc_match_oacc_cache
, ST_OACC_CACHE
);
622 match ("data", gfc_match_oacc_data
, ST_OACC_DATA
);
623 match ("declare", gfc_match_oacc_declare
, ST_OACC_DECLARE
);
626 match ("end data", gfc_match_omp_eos
, ST_OACC_END_DATA
);
627 match ("end host_data", gfc_match_omp_eos
, ST_OACC_END_HOST_DATA
);
628 match ("end kernels loop", gfc_match_omp_eos
, ST_OACC_END_KERNELS_LOOP
);
629 match ("end kernels", gfc_match_omp_eos
, ST_OACC_END_KERNELS
);
630 match ("end loop", gfc_match_omp_eos
, ST_OACC_END_LOOP
);
631 match ("end parallel loop", gfc_match_omp_eos
, ST_OACC_END_PARALLEL_LOOP
);
632 match ("end parallel", gfc_match_omp_eos
, ST_OACC_END_PARALLEL
);
633 match ("enter data", gfc_match_oacc_enter_data
, ST_OACC_ENTER_DATA
);
634 match ("exit data", gfc_match_oacc_exit_data
, ST_OACC_EXIT_DATA
);
637 match ("host_data", gfc_match_oacc_host_data
, ST_OACC_HOST_DATA
);
640 match ("parallel loop", gfc_match_oacc_parallel_loop
, ST_OACC_PARALLEL_LOOP
);
641 match ("parallel", gfc_match_oacc_parallel
, ST_OACC_PARALLEL
);
644 match ("kernels loop", gfc_match_oacc_kernels_loop
, ST_OACC_KERNELS_LOOP
);
645 match ("kernels", gfc_match_oacc_kernels
, ST_OACC_KERNELS
);
648 match ("loop", gfc_match_oacc_loop
, ST_OACC_LOOP
);
651 match ("routine", gfc_match_oacc_routine
, ST_OACC_ROUTINE
);
654 match ("update", gfc_match_oacc_update
, ST_OACC_UPDATE
);
657 match ("wait", gfc_match_oacc_wait
, ST_OACC_WAIT
);
661 /* Directive not found or stored an error message.
662 Check and give up. */
664 if (gfc_error_check () == 0)
665 gfc_error_now ("Unclassifiable OpenACC directive at %C");
669 gfc_error_recovery ();
675 decode_omp_directive (void)
679 bool simd_matched
= false;
681 gfc_enforce_clean_symbol_state ();
683 gfc_clear_error (); /* Clear any pending errors. */
684 gfc_clear_warning (); /* Clear any pending warnings. */
688 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
689 "or ELEMENTAL procedures");
690 gfc_error_recovery ();
694 gfc_unset_implicit_pure (NULL
);
696 old_locus
= gfc_current_locus
;
698 /* General OpenMP directive matching: Instead of testing every possible
699 statement, we eliminate most possibilities by peeking at the
702 c
= gfc_peek_ascii_char ();
704 /* match is for directives that should be recognized only if
705 -fopenmp, matchs for directives that should be recognized
706 if either -fopenmp or -fopenmp-simd. */
710 matcho ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
713 matcho ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
716 matcho ("cancellation% point", gfc_match_omp_cancellation_point
,
717 ST_OMP_CANCELLATION_POINT
);
718 matcho ("cancel", gfc_match_omp_cancel
, ST_OMP_CANCEL
);
719 matcho ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
722 matchs ("declare reduction", gfc_match_omp_declare_reduction
,
723 ST_OMP_DECLARE_REDUCTION
);
724 matchs ("declare simd", gfc_match_omp_declare_simd
,
725 ST_OMP_DECLARE_SIMD
);
726 matcho ("declare target", gfc_match_omp_declare_target
,
727 ST_OMP_DECLARE_TARGET
);
728 matchs ("distribute parallel do simd",
729 gfc_match_omp_distribute_parallel_do_simd
,
730 ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
);
731 matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do
,
732 ST_OMP_DISTRIBUTE_PARALLEL_DO
);
733 matchs ("distribute simd", gfc_match_omp_distribute_simd
,
734 ST_OMP_DISTRIBUTE_SIMD
);
735 matcho ("distribute", gfc_match_omp_distribute
, ST_OMP_DISTRIBUTE
);
736 matchs ("do simd", gfc_match_omp_do_simd
, ST_OMP_DO_SIMD
);
737 matcho ("do", gfc_match_omp_do
, ST_OMP_DO
);
740 matcho ("end atomic", gfc_match_omp_eos
, ST_OMP_END_ATOMIC
);
741 matcho ("end critical", gfc_match_omp_critical
, ST_OMP_END_CRITICAL
);
742 matchs ("end distribute parallel do simd", gfc_match_omp_eos
,
743 ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
);
744 matcho ("end distribute parallel do", gfc_match_omp_eos
,
745 ST_OMP_END_DISTRIBUTE_PARALLEL_DO
);
746 matchs ("end distribute simd", gfc_match_omp_eos
,
747 ST_OMP_END_DISTRIBUTE_SIMD
);
748 matcho ("end distribute", gfc_match_omp_eos
, ST_OMP_END_DISTRIBUTE
);
749 matchs ("end do simd", gfc_match_omp_end_nowait
, ST_OMP_END_DO_SIMD
);
750 matcho ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
751 matchs ("end simd", gfc_match_omp_eos
, ST_OMP_END_SIMD
);
752 matcho ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
753 matcho ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
754 matchs ("end parallel do simd", gfc_match_omp_eos
,
755 ST_OMP_END_PARALLEL_DO_SIMD
);
756 matcho ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
757 matcho ("end parallel sections", gfc_match_omp_eos
,
758 ST_OMP_END_PARALLEL_SECTIONS
);
759 matcho ("end parallel workshare", gfc_match_omp_eos
,
760 ST_OMP_END_PARALLEL_WORKSHARE
);
761 matcho ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
762 matcho ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
763 matcho ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
764 matcho ("end target data", gfc_match_omp_eos
, ST_OMP_END_TARGET_DATA
);
765 matchs ("end target teams distribute parallel do simd",
767 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
768 matcho ("end target teams distribute parallel do", gfc_match_omp_eos
,
769 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
770 matchs ("end target teams distribute simd", gfc_match_omp_eos
,
771 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
);
772 matcho ("end target teams distribute", gfc_match_omp_eos
,
773 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
);
774 matcho ("end target teams", gfc_match_omp_eos
, ST_OMP_END_TARGET_TEAMS
);
775 matcho ("end target", gfc_match_omp_eos
, ST_OMP_END_TARGET
);
776 matcho ("end taskgroup", gfc_match_omp_eos
, ST_OMP_END_TASKGROUP
);
777 matcho ("end task", gfc_match_omp_eos
, ST_OMP_END_TASK
);
778 matchs ("end teams distribute parallel do simd", gfc_match_omp_eos
,
779 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
780 matcho ("end teams distribute parallel do", gfc_match_omp_eos
,
781 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
);
782 matchs ("end teams distribute simd", gfc_match_omp_eos
,
783 ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
);
784 matcho ("end teams distribute", gfc_match_omp_eos
,
785 ST_OMP_END_TEAMS_DISTRIBUTE
);
786 matcho ("end teams", gfc_match_omp_eos
, ST_OMP_END_TEAMS
);
787 matcho ("end workshare", gfc_match_omp_end_nowait
,
788 ST_OMP_END_WORKSHARE
);
791 matcho ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
794 matcho ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
797 matcho ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
800 matchs ("parallel do simd", gfc_match_omp_parallel_do_simd
,
801 ST_OMP_PARALLEL_DO_SIMD
);
802 matcho ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
803 matcho ("parallel sections", gfc_match_omp_parallel_sections
,
804 ST_OMP_PARALLEL_SECTIONS
);
805 matcho ("parallel workshare", gfc_match_omp_parallel_workshare
,
806 ST_OMP_PARALLEL_WORKSHARE
);
807 matcho ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
810 matcho ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
811 matcho ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
812 matchs ("simd", gfc_match_omp_simd
, ST_OMP_SIMD
);
813 matcho ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
816 matcho ("target data", gfc_match_omp_target_data
, ST_OMP_TARGET_DATA
);
817 matchs ("target teams distribute parallel do simd",
818 gfc_match_omp_target_teams_distribute_parallel_do_simd
,
819 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
820 matcho ("target teams distribute parallel do",
821 gfc_match_omp_target_teams_distribute_parallel_do
,
822 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
823 matchs ("target teams distribute simd",
824 gfc_match_omp_target_teams_distribute_simd
,
825 ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
);
826 matcho ("target teams distribute", gfc_match_omp_target_teams_distribute
,
827 ST_OMP_TARGET_TEAMS_DISTRIBUTE
);
828 matcho ("target teams", gfc_match_omp_target_teams
, ST_OMP_TARGET_TEAMS
);
829 matcho ("target update", gfc_match_omp_target_update
,
830 ST_OMP_TARGET_UPDATE
);
831 matcho ("target", gfc_match_omp_target
, ST_OMP_TARGET
);
832 matcho ("taskgroup", gfc_match_omp_taskgroup
, ST_OMP_TASKGROUP
);
833 matcho ("taskwait", gfc_match_omp_taskwait
, ST_OMP_TASKWAIT
);
834 matcho ("taskyield", gfc_match_omp_taskyield
, ST_OMP_TASKYIELD
);
835 matcho ("task", gfc_match_omp_task
, ST_OMP_TASK
);
836 matchs ("teams distribute parallel do simd",
837 gfc_match_omp_teams_distribute_parallel_do_simd
,
838 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
839 matcho ("teams distribute parallel do",
840 gfc_match_omp_teams_distribute_parallel_do
,
841 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
);
842 matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd
,
843 ST_OMP_TEAMS_DISTRIBUTE_SIMD
);
844 matcho ("teams distribute", gfc_match_omp_teams_distribute
,
845 ST_OMP_TEAMS_DISTRIBUTE
);
846 matcho ("teams", gfc_match_omp_teams
, ST_OMP_TEAMS
);
847 matcho ("threadprivate", gfc_match_omp_threadprivate
,
848 ST_OMP_THREADPRIVATE
);
851 matcho ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
855 /* All else has failed, so give up. See if any of the matchers has
856 stored an error message of some sort. Don't error out if
857 not -fopenmp and simd_matched is false, i.e. if a directive other
858 than one marked with match has been seen. */
860 if (flag_openmp
|| simd_matched
)
862 if (!gfc_error_check ())
863 gfc_error_now ("Unclassifiable OpenMP directive at %C");
868 gfc_error_recovery ();
874 decode_gcc_attribute (void)
878 gfc_enforce_clean_symbol_state ();
880 gfc_clear_error (); /* Clear any pending errors. */
881 gfc_clear_warning (); /* Clear any pending warnings. */
882 old_locus
= gfc_current_locus
;
884 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
886 /* All else has failed, so give up. See if any of the matchers has
887 stored an error message of some sort. */
889 if (!gfc_error_check ())
890 gfc_error_now ("Unclassifiable GCC directive at %C");
894 gfc_error_recovery ();
901 /* Assert next length characters to be equal to token in free form. */
904 verify_token_free (const char* token
, int length
, bool last_was_use_stmt
)
909 c
= gfc_next_ascii_char ();
910 for (i
= 0; i
< length
; i
++, c
= gfc_next_ascii_char ())
911 gcc_assert (c
== token
[i
]);
913 gcc_assert (gfc_is_whitespace(c
));
914 gfc_gobble_whitespace ();
915 if (last_was_use_stmt
)
919 /* Get the next statement in free form source. */
928 at_bol
= gfc_at_bol ();
929 gfc_gobble_whitespace ();
931 c
= gfc_peek_ascii_char ();
937 /* Found a statement label? */
938 m
= gfc_match_st_label (&gfc_statement_label
);
940 d
= gfc_peek_ascii_char ();
941 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
943 gfc_match_small_literal_int (&i
, &cnt
);
946 gfc_error_now ("Too many digits in statement label at %C");
949 gfc_error_now ("Zero is not a valid statement label at %C");
952 c
= gfc_next_ascii_char ();
955 if (!gfc_is_whitespace (c
))
956 gfc_error_now ("Non-numeric character in statement label at %C");
962 label_locus
= gfc_current_locus
;
964 gfc_gobble_whitespace ();
966 if (at_bol
&& gfc_peek_ascii_char () == ';')
968 gfc_error_now ("Semicolon at %C needs to be preceded by "
970 gfc_next_ascii_char (); /* Eat up the semicolon. */
974 if (gfc_match_eos () == MATCH_YES
)
976 gfc_warning_now (0, "Ignoring statement label in empty statement "
977 "at %L", &label_locus
);
978 gfc_free_st_label (gfc_statement_label
);
979 gfc_statement_label
= NULL
;
986 /* Comments have already been skipped by the time we get here,
987 except for GCC attributes and OpenMP/OpenACC directives. */
989 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
990 c
= gfc_peek_ascii_char ();
996 c
= gfc_next_ascii_char ();
997 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
998 gcc_assert (c
== "gcc$"[i
]);
1000 gfc_gobble_whitespace ();
1001 return decode_gcc_attribute ();
1006 /* Since both OpenMP and OpenACC directives starts with
1007 !$ character sequence, we must check all flags combinations */
1008 if ((flag_openmp
|| flag_openmp_simd
)
1011 verify_token_free ("$omp", 4, last_was_use_stmt
);
1012 return decode_omp_directive ();
1014 else if ((flag_openmp
|| flag_openmp_simd
)
1017 gfc_next_ascii_char (); /* Eat up dollar character */
1018 c
= gfc_peek_ascii_char ();
1022 verify_token_free ("omp", 3, last_was_use_stmt
);
1023 return decode_omp_directive ();
1027 verify_token_free ("acc", 3, last_was_use_stmt
);
1028 return decode_oacc_directive ();
1031 else if (flag_openacc
)
1033 verify_token_free ("$acc", 4, last_was_use_stmt
);
1034 return decode_oacc_directive ();
1040 if (at_bol
&& c
== ';')
1042 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1043 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1045 gfc_next_ascii_char (); /* Eat up the semicolon. */
1049 return decode_statement ();
1052 /* Assert next length characters to be equal to token in fixed form. */
1055 verify_token_fixed (const char *token
, int length
, bool last_was_use_stmt
)
1058 char c
= gfc_next_char_literal (NONSTRING
);
1060 for (i
= 0; i
< length
; i
++, c
= gfc_next_char_literal (NONSTRING
))
1061 gcc_assert ((char) gfc_wide_tolower (c
) == token
[i
]);
1063 if (c
!= ' ' && c
!= '0')
1065 gfc_buffer_error (false);
1066 gfc_error ("Bad continuation line at %C");
1069 if (last_was_use_stmt
)
1075 /* Get the next statement in fixed-form source. */
1077 static gfc_statement
1080 int label
, digit_flag
, i
;
1085 return decode_statement ();
1087 /* Skip past the current label field, parsing a statement label if
1088 one is there. This is a weird number parser, since the number is
1089 contained within five columns and can have any kind of embedded
1090 spaces. We also check for characters that make the rest of the
1096 for (i
= 0; i
< 5; i
++)
1098 c
= gfc_next_char_literal (NONSTRING
);
1115 label
= label
* 10 + ((unsigned char) c
- '0');
1116 label_locus
= gfc_current_locus
;
1120 /* Comments have already been skipped by the time we get
1121 here, except for GCC attributes and OpenMP directives. */
1124 c
= gfc_next_char_literal (NONSTRING
);
1126 if (TOLOWER (c
) == 'g')
1128 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
1129 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
1131 return decode_gcc_attribute ();
1135 if ((flag_openmp
|| flag_openmp_simd
)
1138 if (!verify_token_fixed ("omp", 3, last_was_use_stmt
))
1140 return decode_omp_directive ();
1142 else if ((flag_openmp
|| flag_openmp_simd
)
1145 c
= gfc_next_char_literal(NONSTRING
);
1146 if (c
== 'o' || c
== 'O')
1148 if (!verify_token_fixed ("mp", 2, last_was_use_stmt
))
1150 return decode_omp_directive ();
1152 else if (c
== 'a' || c
== 'A')
1154 if (!verify_token_fixed ("cc", 2, last_was_use_stmt
))
1156 return decode_oacc_directive ();
1159 else if (flag_openacc
)
1161 if (!verify_token_fixed ("acc", 3, last_was_use_stmt
))
1163 return decode_oacc_directive ();
1168 /* Comments have already been skipped by the time we get
1169 here so don't bother checking for them. */
1172 gfc_buffer_error (false);
1173 gfc_error ("Non-numeric character in statement label at %C");
1181 gfc_warning_now (0, "Zero is not a valid statement label at %C");
1184 /* We've found a valid statement label. */
1185 gfc_statement_label
= gfc_get_st_label (label
);
1189 /* Since this line starts a statement, it cannot be a continuation
1190 of a previous statement. If we see something here besides a
1191 space or zero, it must be a bad continuation line. */
1193 c
= gfc_next_char_literal (NONSTRING
);
1197 if (c
!= ' ' && c
!= '0')
1199 gfc_buffer_error (false);
1200 gfc_error ("Bad continuation line at %C");
1204 /* Now that we've taken care of the statement label columns, we have
1205 to make sure that the first nonblank character is not a '!'. If
1206 it is, the rest of the line is a comment. */
1210 loc
= gfc_current_locus
;
1211 c
= gfc_next_char_literal (NONSTRING
);
1213 while (gfc_is_whitespace (c
));
1217 gfc_current_locus
= loc
;
1222 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1223 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1224 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1229 if (gfc_match_eos () == MATCH_YES
)
1232 /* At this point, we've got a nonblank statement to parse. */
1233 return decode_statement ();
1237 gfc_warning_now (0, "Ignoring statement label in empty statement at %L",
1240 gfc_current_locus
.lb
->truncated
= 0;
1241 gfc_advance_line ();
1246 /* Return the next non-ST_NONE statement to the caller. We also worry
1247 about including files and the ends of include files at this stage. */
1249 static gfc_statement
1250 next_statement (void)
1255 gfc_enforce_clean_symbol_state ();
1257 gfc_new_block
= NULL
;
1259 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
1260 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1261 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
1264 gfc_statement_label
= NULL
;
1265 gfc_buffer_error (true);
1268 gfc_advance_line ();
1270 gfc_skip_comments ();
1278 if (gfc_define_undef_line ())
1281 old_locus
= gfc_current_locus
;
1283 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1289 gfc_buffer_error (false);
1291 if (st
== ST_GET_FCN_CHARACTERISTICS
&& gfc_statement_label
!= NULL
)
1293 gfc_free_st_label (gfc_statement_label
);
1294 gfc_statement_label
= NULL
;
1295 gfc_current_locus
= old_locus
;
1299 check_statement_label (st
);
1305 /****************************** Parser ***********************************/
1307 /* The parser subroutines are of type 'try' that fail if the file ends
1310 /* Macros that expand to case-labels for various classes of
1311 statements. Start with executable statements that directly do
1314 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1315 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1316 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1317 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1318 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1319 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1320 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1321 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1322 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1323 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
1324 case ST_OMP_TARGET_UPDATE: case ST_ERROR_STOP: case ST_SYNC_ALL: \
1325 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1326 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1327 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1329 /* Statements that mark other executable statements. */
1331 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1332 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1333 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1334 case ST_OMP_PARALLEL: \
1335 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1336 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
1337 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1338 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1339 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1340 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1341 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1342 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1343 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1344 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1345 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1346 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1347 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1348 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1349 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1350 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1351 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: \
1353 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1354 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: case ST_OACC_KERNELS_LOOP
1356 /* Declaration statements */
1358 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1359 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1360 case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
1361 case ST_PROCEDURE: case ST_OMP_DECLARE_SIMD: case ST_OMP_DECLARE_REDUCTION: \
1362 case ST_OMP_DECLARE_TARGET: case ST_OACC_ROUTINE
1364 /* Block end statements. Errors associated with interchanging these
1365 are detected in gfc_match_end(). */
1367 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1368 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1369 case ST_END_BLOCK: case ST_END_ASSOCIATE
1372 /* Push a new state onto the stack. */
1375 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1377 p
->state
= new_state
;
1378 p
->previous
= gfc_state_stack
;
1380 p
->head
= p
->tail
= NULL
;
1381 p
->do_variable
= NULL
;
1382 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1383 p
->ext
.oacc_declare_clauses
= NULL
;
1385 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1386 construct statement was accepted right before pushing the state. Thus,
1387 the construct's gfc_code is available as tail of the parent state. */
1388 gcc_assert (gfc_state_stack
);
1389 p
->construct
= gfc_state_stack
->tail
;
1391 gfc_state_stack
= p
;
1395 /* Pop the current state. */
1399 gfc_state_stack
= gfc_state_stack
->previous
;
1403 /* Try to find the given state in the state stack. */
1406 gfc_find_state (gfc_compile_state state
)
1410 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1411 if (p
->state
== state
)
1414 return (p
== NULL
) ? false : true;
1418 /* Starts a new level in the statement list. */
1421 new_level (gfc_code
*q
)
1425 p
= q
->block
= gfc_get_code (EXEC_NOP
);
1427 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1433 /* Add the current new_st code structure and adds it to the current
1434 program unit. As a side-effect, it zeroes the new_st. */
1437 add_statement (void)
1441 p
= XCNEW (gfc_code
);
1444 p
->loc
= gfc_current_locus
;
1446 if (gfc_state_stack
->head
== NULL
)
1447 gfc_state_stack
->head
= p
;
1449 gfc_state_stack
->tail
->next
= p
;
1451 while (p
->next
!= NULL
)
1454 gfc_state_stack
->tail
= p
;
1456 gfc_clear_new_st ();
1462 /* Frees everything associated with the current statement. */
1465 undo_new_statement (void)
1467 gfc_free_statements (new_st
.block
);
1468 gfc_free_statements (new_st
.next
);
1469 gfc_free_statement (&new_st
);
1470 gfc_clear_new_st ();
1474 /* If the current statement has a statement label, make sure that it
1475 is allowed to, or should have one. */
1478 check_statement_label (gfc_statement st
)
1482 if (gfc_statement_label
== NULL
)
1484 if (st
== ST_FORMAT
)
1485 gfc_error ("FORMAT statement at %L does not have a statement label",
1492 case ST_END_PROGRAM
:
1493 case ST_END_FUNCTION
:
1494 case ST_END_SUBROUTINE
:
1498 case ST_END_CRITICAL
:
1500 case ST_END_ASSOCIATE
:
1503 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
1504 type
= ST_LABEL_DO_TARGET
;
1506 type
= ST_LABEL_TARGET
;
1510 type
= ST_LABEL_FORMAT
;
1513 /* Statement labels are not restricted from appearing on a
1514 particular line. However, there are plenty of situations
1515 where the resulting label can't be referenced. */
1518 type
= ST_LABEL_BAD_TARGET
;
1522 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1524 new_st
.here
= gfc_statement_label
;
1528 /* Figures out what the enclosing program unit is. This will be a
1529 function, subroutine, program, block data or module. */
1532 gfc_enclosing_unit (gfc_compile_state
* result
)
1536 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1537 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1538 || p
->state
== COMP_MODULE
|| p
->state
== COMP_BLOCK_DATA
1539 || p
->state
== COMP_PROGRAM
)
1548 *result
= COMP_PROGRAM
;
1553 /* Translate a statement enum to a string. */
1556 gfc_ascii_statement (gfc_statement st
)
1562 case ST_ARITHMETIC_IF
:
1563 p
= _("arithmetic IF");
1572 p
= _("attribute declaration");
1608 p
= _("data declaration");
1616 case ST_DERIVED_DECL
:
1617 p
= _("derived type declaration");
1631 case ST_END_ASSOCIATE
:
1632 p
= "END ASSOCIATE";
1637 case ST_END_BLOCK_DATA
:
1638 p
= "END BLOCK DATA";
1640 case ST_END_CRITICAL
:
1652 case ST_END_FUNCTION
:
1658 case ST_END_INTERFACE
:
1659 p
= "END INTERFACE";
1664 case ST_END_PROGRAM
:
1670 case ST_END_SUBROUTINE
:
1671 p
= "END SUBROUTINE";
1682 case ST_EQUIVALENCE
:
1694 case ST_FORALL_BLOCK
: /* Fall through */
1716 case ST_IMPLICIT_NONE
:
1717 p
= "IMPLICIT NONE";
1719 case ST_IMPLIED_ENDDO
:
1720 p
= _("implied END DO");
1749 case ST_MODULE_PROC
:
1750 p
= "MODULE PROCEDURE";
1782 case ST_SYNC_IMAGES
:
1785 case ST_SYNC_MEMORY
:
1800 case ST_WHERE_BLOCK
: /* Fall through */
1811 p
= _("assignment");
1813 case ST_POINTER_ASSIGNMENT
:
1814 p
= _("pointer assignment");
1816 case ST_SELECT_CASE
:
1819 case ST_SELECT_TYPE
:
1834 case ST_STATEMENT_FUNCTION
:
1835 p
= "STATEMENT FUNCTION";
1837 case ST_LABEL_ASSIGNMENT
:
1838 p
= "LABEL ASSIGNMENT";
1841 p
= "ENUM DEFINITION";
1844 p
= "ENUMERATOR DEFINITION";
1849 case ST_OACC_PARALLEL_LOOP
:
1850 p
= "!$ACC PARALLEL LOOP";
1852 case ST_OACC_END_PARALLEL_LOOP
:
1853 p
= "!$ACC END PARALLEL LOOP";
1855 case ST_OACC_PARALLEL
:
1856 p
= "!$ACC PARALLEL";
1858 case ST_OACC_END_PARALLEL
:
1859 p
= "!$ACC END PARALLEL";
1861 case ST_OACC_KERNELS
:
1862 p
= "!$ACC KERNELS";
1864 case ST_OACC_END_KERNELS
:
1865 p
= "!$ACC END KERNELS";
1867 case ST_OACC_KERNELS_LOOP
:
1868 p
= "!$ACC KERNELS LOOP";
1870 case ST_OACC_END_KERNELS_LOOP
:
1871 p
= "!$ACC END KERNELS LOOP";
1876 case ST_OACC_END_DATA
:
1877 p
= "!$ACC END DATA";
1879 case ST_OACC_HOST_DATA
:
1880 p
= "!$ACC HOST_DATA";
1882 case ST_OACC_END_HOST_DATA
:
1883 p
= "!$ACC END HOST_DATA";
1888 case ST_OACC_END_LOOP
:
1889 p
= "!$ACC END LOOP";
1891 case ST_OACC_DECLARE
:
1892 p
= "!$ACC DECLARE";
1894 case ST_OACC_UPDATE
:
1903 case ST_OACC_ENTER_DATA
:
1904 p
= "!$ACC ENTER DATA";
1906 case ST_OACC_EXIT_DATA
:
1907 p
= "!$ACC EXIT DATA";
1909 case ST_OACC_ROUTINE
:
1910 p
= "!$ACC ROUTINE";
1915 case ST_OMP_BARRIER
:
1916 p
= "!$OMP BARRIER";
1921 case ST_OMP_CANCELLATION_POINT
:
1922 p
= "!$OMP CANCELLATION POINT";
1924 case ST_OMP_CRITICAL
:
1925 p
= "!$OMP CRITICAL";
1927 case ST_OMP_DECLARE_REDUCTION
:
1928 p
= "!$OMP DECLARE REDUCTION";
1930 case ST_OMP_DECLARE_SIMD
:
1931 p
= "!$OMP DECLARE SIMD";
1933 case ST_OMP_DECLARE_TARGET
:
1934 p
= "!$OMP DECLARE TARGET";
1936 case ST_OMP_DISTRIBUTE
:
1937 p
= "!$OMP DISTRIBUTE";
1939 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
1940 p
= "!$OMP DISTRIBUTE PARALLEL DO";
1942 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
1943 p
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
1945 case ST_OMP_DISTRIBUTE_SIMD
:
1946 p
= "!$OMP DISTRIBUTE SIMD";
1951 case ST_OMP_DO_SIMD
:
1952 p
= "!$OMP DO SIMD";
1954 case ST_OMP_END_ATOMIC
:
1955 p
= "!$OMP END ATOMIC";
1957 case ST_OMP_END_CRITICAL
:
1958 p
= "!$OMP END CRITICAL";
1960 case ST_OMP_END_DISTRIBUTE
:
1961 p
= "!$OMP END DISTRIBUTE";
1963 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO
:
1964 p
= "!$OMP END DISTRIBUTE PARALLEL DO";
1966 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
:
1967 p
= "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
1969 case ST_OMP_END_DISTRIBUTE_SIMD
:
1970 p
= "!$OMP END DISTRIBUTE SIMD";
1975 case ST_OMP_END_DO_SIMD
:
1976 p
= "!$OMP END DO SIMD";
1978 case ST_OMP_END_SIMD
:
1979 p
= "!$OMP END SIMD";
1981 case ST_OMP_END_MASTER
:
1982 p
= "!$OMP END MASTER";
1984 case ST_OMP_END_ORDERED
:
1985 p
= "!$OMP END ORDERED";
1987 case ST_OMP_END_PARALLEL
:
1988 p
= "!$OMP END PARALLEL";
1990 case ST_OMP_END_PARALLEL_DO
:
1991 p
= "!$OMP END PARALLEL DO";
1993 case ST_OMP_END_PARALLEL_DO_SIMD
:
1994 p
= "!$OMP END PARALLEL DO SIMD";
1996 case ST_OMP_END_PARALLEL_SECTIONS
:
1997 p
= "!$OMP END PARALLEL SECTIONS";
1999 case ST_OMP_END_PARALLEL_WORKSHARE
:
2000 p
= "!$OMP END PARALLEL WORKSHARE";
2002 case ST_OMP_END_SECTIONS
:
2003 p
= "!$OMP END SECTIONS";
2005 case ST_OMP_END_SINGLE
:
2006 p
= "!$OMP END SINGLE";
2008 case ST_OMP_END_TASK
:
2009 p
= "!$OMP END TASK";
2011 case ST_OMP_END_TARGET
:
2012 p
= "!$OMP END TARGET";
2014 case ST_OMP_END_TARGET_DATA
:
2015 p
= "!$OMP END TARGET DATA";
2017 case ST_OMP_END_TARGET_TEAMS
:
2018 p
= "!$OMP END TARGET TEAMS";
2020 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
:
2021 p
= "!$OMP END TARGET TEAMS DISTRIBUTE";
2023 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2024 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2026 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2027 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2029 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2030 p
= "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2032 case ST_OMP_END_TASKGROUP
:
2033 p
= "!$OMP END TASKGROUP";
2035 case ST_OMP_END_TEAMS
:
2036 p
= "!$OMP END TEAMS";
2038 case ST_OMP_END_TEAMS_DISTRIBUTE
:
2039 p
= "!$OMP END TEAMS DISTRIBUTE";
2041 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2042 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2044 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2045 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2047 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
:
2048 p
= "!$OMP END TEAMS DISTRIBUTE SIMD";
2050 case ST_OMP_END_WORKSHARE
:
2051 p
= "!$OMP END WORKSHARE";
2059 case ST_OMP_ORDERED
:
2060 p
= "!$OMP ORDERED";
2062 case ST_OMP_PARALLEL
:
2063 p
= "!$OMP PARALLEL";
2065 case ST_OMP_PARALLEL_DO
:
2066 p
= "!$OMP PARALLEL DO";
2068 case ST_OMP_PARALLEL_DO_SIMD
:
2069 p
= "!$OMP PARALLEL DO SIMD";
2071 case ST_OMP_PARALLEL_SECTIONS
:
2072 p
= "!$OMP PARALLEL SECTIONS";
2074 case ST_OMP_PARALLEL_WORKSHARE
:
2075 p
= "!$OMP PARALLEL WORKSHARE";
2077 case ST_OMP_SECTIONS
:
2078 p
= "!$OMP SECTIONS";
2080 case ST_OMP_SECTION
:
2081 p
= "!$OMP SECTION";
2092 case ST_OMP_TARGET_DATA
:
2093 p
= "!$OMP TARGET DATA";
2095 case ST_OMP_TARGET_TEAMS
:
2096 p
= "!$OMP TARGET TEAMS";
2098 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
2099 p
= "!$OMP TARGET TEAMS DISTRIBUTE";
2101 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2102 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2104 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2105 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2107 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2108 p
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2110 case ST_OMP_TARGET_UPDATE
:
2111 p
= "!$OMP TARGET UPDATE";
2116 case ST_OMP_TASKGROUP
:
2117 p
= "!$OMP TASKGROUP";
2119 case ST_OMP_TASKWAIT
:
2120 p
= "!$OMP TASKWAIT";
2122 case ST_OMP_TASKYIELD
:
2123 p
= "!$OMP TASKYIELD";
2128 case ST_OMP_TEAMS_DISTRIBUTE
:
2129 p
= "!$OMP TEAMS DISTRIBUTE";
2131 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2132 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2134 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2135 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2137 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
2138 p
= "!$OMP TEAMS DISTRIBUTE SIMD";
2140 case ST_OMP_THREADPRIVATE
:
2141 p
= "!$OMP THREADPRIVATE";
2143 case ST_OMP_WORKSHARE
:
2144 p
= "!$OMP WORKSHARE";
2147 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2154 /* Create a symbol for the main program and assign it to ns->proc_name. */
2157 main_program_symbol (gfc_namespace
*ns
, const char *name
)
2159 gfc_symbol
*main_program
;
2160 symbol_attribute attr
;
2162 gfc_get_symbol (name
, ns
, &main_program
);
2163 gfc_clear_attr (&attr
);
2164 attr
.flavor
= FL_PROGRAM
;
2165 attr
.proc
= PROC_UNKNOWN
;
2166 attr
.subroutine
= 1;
2167 attr
.access
= ACCESS_PUBLIC
;
2168 attr
.is_main_program
= 1;
2169 main_program
->attr
= attr
;
2170 main_program
->declared_at
= gfc_current_locus
;
2171 ns
->proc_name
= main_program
;
2172 gfc_commit_symbols ();
2176 /* Do whatever is necessary to accept the last statement. */
2179 accept_statement (gfc_statement st
)
2183 case ST_IMPLICIT_NONE
:
2190 gfc_current_ns
->proc_name
= gfc_new_block
;
2193 /* If the statement is the end of a block, lay down a special code
2194 that allows a branch to the end of the block from within the
2195 construct. IF and SELECT are treated differently from DO
2196 (where EXEC_NOP is added inside the loop) for two
2198 1. END DO has a meaning in the sense that after a GOTO to
2199 it, the loop counter must be increased.
2200 2. IF blocks and SELECT blocks can consist of multiple
2201 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
2202 Putting the label before the END IF would make the jump
2203 from, say, the ELSE IF block to the END IF illegal. */
2207 case ST_END_CRITICAL
:
2208 if (gfc_statement_label
!= NULL
)
2210 new_st
.op
= EXEC_END_NESTED_BLOCK
;
2215 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
2216 one parallel block. Thus, we add the special code to the nested block
2217 itself, instead of the parent one. */
2219 case ST_END_ASSOCIATE
:
2220 if (gfc_statement_label
!= NULL
)
2222 new_st
.op
= EXEC_END_BLOCK
;
2227 /* The end-of-program unit statements do not get the special
2228 marker and require a statement of some sort if they are a
2231 case ST_END_PROGRAM
:
2232 case ST_END_FUNCTION
:
2233 case ST_END_SUBROUTINE
:
2234 if (gfc_statement_label
!= NULL
)
2236 new_st
.op
= EXEC_RETURN
;
2241 new_st
.op
= EXEC_END_PROCEDURE
;
2257 gfc_commit_symbols ();
2258 gfc_warning_check ();
2259 gfc_clear_new_st ();
2263 /* Undo anything tentative that has been built for the current
2267 reject_statement (void)
2269 /* Revert to the previous charlen chain. */
2270 gfc_free_charlen (gfc_current_ns
->cl_list
, gfc_current_ns
->old_cl_list
);
2271 gfc_current_ns
->cl_list
= gfc_current_ns
->old_cl_list
;
2273 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
2274 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
2276 gfc_reject_data (gfc_current_ns
);
2278 gfc_new_block
= NULL
;
2279 gfc_undo_symbols ();
2280 gfc_clear_warning ();
2281 undo_new_statement ();
2285 /* Generic complaint about an out of order statement. We also do
2286 whatever is necessary to clean up. */
2289 unexpected_statement (gfc_statement st
)
2291 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
2293 reject_statement ();
2297 /* Given the next statement seen by the matcher, make sure that it is
2298 in proper order with the last. This subroutine is initialized by
2299 calling it with an argument of ST_NONE. If there is a problem, we
2300 issue an error and return false. Otherwise we return true.
2302 Individual parsers need to verify that the statements seen are
2303 valid before calling here, i.e., ENTRY statements are not allowed in
2304 INTERFACE blocks. The following diagram is taken from the standard:
2306 +---------------------------------------+
2307 | program subroutine function module |
2308 +---------------------------------------+
2310 +---------------------------------------+
2312 +---------------------------------------+
2314 | +-----------+------------------+
2315 | | parameter | implicit |
2316 | +-----------+------------------+
2317 | format | | derived type |
2318 | entry | parameter | interface |
2319 | | data | specification |
2320 | | | statement func |
2321 | +-----------+------------------+
2322 | | data | executable |
2323 +--------+-----------+------------------+
2325 +---------------------------------------+
2326 | internal module/subprogram |
2327 +---------------------------------------+
2329 +---------------------------------------+
2338 ORDER_IMPLICIT_NONE
,
2346 enum state_order state
;
2347 gfc_statement last_statement
;
2353 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
2359 p
->state
= ORDER_START
;
2363 if (p
->state
> ORDER_USE
)
2365 p
->state
= ORDER_USE
;
2369 if (p
->state
> ORDER_IMPORT
)
2371 p
->state
= ORDER_IMPORT
;
2374 case ST_IMPLICIT_NONE
:
2375 if (p
->state
> ORDER_IMPLICIT
)
2378 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2379 statement disqualifies a USE but not an IMPLICIT NONE.
2380 Duplicate IMPLICIT NONEs are caught when the implicit types
2383 p
->state
= ORDER_IMPLICIT_NONE
;
2387 if (p
->state
> ORDER_IMPLICIT
)
2389 p
->state
= ORDER_IMPLICIT
;
2394 if (p
->state
< ORDER_IMPLICIT_NONE
)
2395 p
->state
= ORDER_IMPLICIT_NONE
;
2399 if (p
->state
>= ORDER_EXEC
)
2401 if (p
->state
< ORDER_IMPLICIT
)
2402 p
->state
= ORDER_IMPLICIT
;
2406 if (p
->state
< ORDER_SPEC
)
2407 p
->state
= ORDER_SPEC
;
2412 case ST_DERIVED_DECL
:
2413 case ST_OACC_DECLARE
:
2415 if (p
->state
>= ORDER_EXEC
)
2417 if (p
->state
< ORDER_SPEC
)
2418 p
->state
= ORDER_SPEC
;
2423 if (p
->state
< ORDER_EXEC
)
2424 p
->state
= ORDER_EXEC
;
2431 /* All is well, record the statement in case we need it next time. */
2432 p
->where
= gfc_current_locus
;
2433 p
->last_statement
= st
;
2438 gfc_error_1 ("%s statement at %C cannot follow %s statement at %L",
2439 gfc_ascii_statement (st
),
2440 gfc_ascii_statement (p
->last_statement
), &p
->where
);
2446 /* Handle an unexpected end of file. This is a show-stopper... */
2448 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
2451 unexpected_eof (void)
2455 gfc_error ("Unexpected end of file in %qs", gfc_source_file
);
2457 /* Memory cleanup. Move to "second to last". */
2458 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
2461 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
2464 longjmp (eof_buf
, 1);
2468 /* Parse the CONTAINS section of a derived type definition. */
2470 gfc_access gfc_typebound_default_access
;
2473 parse_derived_contains (void)
2476 bool seen_private
= false;
2477 bool seen_comps
= false;
2478 bool error_flag
= false;
2481 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2482 gcc_assert (gfc_current_block ());
2484 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
2486 if (gfc_current_block ()->attr
.sequence
)
2487 gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
2488 " section at %C", gfc_current_block ()->name
);
2489 if (gfc_current_block ()->attr
.is_bind_c
)
2490 gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
2491 " section at %C", gfc_current_block ()->name
);
2493 accept_statement (ST_CONTAINS
);
2494 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
2496 gfc_typebound_default_access
= ACCESS_PUBLIC
;
2502 st
= next_statement ();
2510 gfc_error ("Components in TYPE at %C must precede CONTAINS");
2514 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
2517 accept_statement (ST_PROCEDURE
);
2522 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
2525 accept_statement (ST_GENERIC
);
2530 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
2534 accept_statement (ST_FINAL
);
2542 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
2543 "at %C with empty CONTAINS section")))
2546 /* ST_END_TYPE is accepted by parse_derived after return. */
2550 if (!gfc_find_state (COMP_MODULE
))
2552 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2559 gfc_error ("PRIVATE statement at %C must precede procedure"
2566 gfc_error ("Duplicate PRIVATE statement at %C");
2570 accept_statement (ST_PRIVATE
);
2571 gfc_typebound_default_access
= ACCESS_PRIVATE
;
2572 seen_private
= true;
2576 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2580 gfc_error ("Already inside a CONTAINS block at %C");
2584 unexpected_statement (st
);
2592 reject_statement ();
2596 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2602 /* Parse a derived type. */
2605 parse_derived (void)
2607 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
2611 gfc_component
*c
, *lock_comp
= NULL
;
2613 accept_statement (ST_DERIVED_DECL
);
2614 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
2616 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
2623 while (compiling_type
)
2625 st
= next_statement ();
2633 accept_statement (st
);
2638 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
2645 if (!seen_component
)
2646 gfc_notify_std (GFC_STD_F2003
, "Derived type "
2647 "definition at %C without components");
2649 accept_statement (ST_END_TYPE
);
2653 if (!gfc_find_state (COMP_MODULE
))
2655 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2662 gfc_error ("PRIVATE statement at %C must precede "
2663 "structure components");
2668 gfc_error ("Duplicate PRIVATE statement at %C");
2670 s
.sym
->component_access
= ACCESS_PRIVATE
;
2672 accept_statement (ST_PRIVATE
);
2679 gfc_error ("SEQUENCE statement at %C must precede "
2680 "structure components");
2684 if (gfc_current_block ()->attr
.sequence
)
2685 gfc_warning (0, "SEQUENCE attribute at %C already specified in "
2690 gfc_error ("Duplicate SEQUENCE statement at %C");
2694 gfc_add_sequence (&gfc_current_block ()->attr
,
2695 gfc_current_block ()->name
, NULL
);
2699 gfc_notify_std (GFC_STD_F2003
,
2700 "CONTAINS block in derived type"
2701 " definition at %C");
2703 accept_statement (ST_CONTAINS
);
2704 parse_derived_contains ();
2708 unexpected_statement (st
);
2713 /* need to verify that all fields of the derived type are
2714 * interoperable with C if the type is declared to be bind(c)
2716 sym
= gfc_current_block ();
2717 for (c
= sym
->components
; c
; c
= c
->next
)
2719 bool coarray
, lock_type
, allocatable
, pointer
;
2720 coarray
= lock_type
= allocatable
= pointer
= false;
2722 /* Look for allocatable components. */
2723 if (c
->attr
.allocatable
2724 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2725 && CLASS_DATA (c
)->attr
.allocatable
)
2726 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
2727 && c
->ts
.u
.derived
->attr
.alloc_comp
))
2730 sym
->attr
.alloc_comp
= 1;
2733 /* Look for pointer components. */
2735 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2736 && CLASS_DATA (c
)->attr
.class_pointer
)
2737 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
2740 sym
->attr
.pointer_comp
= 1;
2743 /* Look for procedure pointer components. */
2744 if (c
->attr
.proc_pointer
2745 || (c
->ts
.type
== BT_DERIVED
2746 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
2747 sym
->attr
.proc_pointer_comp
= 1;
2749 /* Looking for coarray components. */
2750 if (c
->attr
.codimension
2751 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2752 && CLASS_DATA (c
)->attr
.codimension
))
2755 sym
->attr
.coarray_comp
= 1;
2758 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
2759 && !c
->attr
.pointer
)
2762 sym
->attr
.coarray_comp
= 1;
2765 /* Looking for lock_type components. */
2766 if ((c
->ts
.type
== BT_DERIVED
2767 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2768 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2769 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2770 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2771 == INTMOD_ISO_FORTRAN_ENV
2772 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2773 == ISOFORTRAN_LOCK_TYPE
)
2774 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
2775 && !allocatable
&& !pointer
))
2779 sym
->attr
.lock_comp
= 1;
2782 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2783 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2784 unless there are nondirect [allocatable or pointer] components
2785 involved (cf. 1.3.33.1 and 1.3.33.3). */
2787 if (pointer
&& !coarray
&& lock_type
)
2788 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2789 "codimension or be a subcomponent of a coarray, "
2790 "which is not possible as the component has the "
2791 "pointer attribute", c
->name
, &c
->loc
);
2792 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
2793 && c
->ts
.u
.derived
->attr
.lock_comp
)
2794 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2795 "of type LOCK_TYPE, which must have a codimension or be a "
2796 "subcomponent of a coarray", c
->name
, &c
->loc
);
2798 if (lock_type
&& allocatable
&& !coarray
)
2799 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
2800 "a codimension", c
->name
, &c
->loc
);
2801 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
2802 && c
->ts
.u
.derived
->attr
.lock_comp
)
2803 gfc_error ("Allocatable component %s at %L must have a codimension as "
2804 "it has a noncoarray subcomponent of type LOCK_TYPE",
2807 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
2808 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2809 "subcomponent of type LOCK_TYPE must have a codimension or "
2810 "be a subcomponent of a coarray. (Variables of type %s may "
2811 "not have a codimension as already a coarray "
2812 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
2814 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
2815 gfc_error_1 ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2816 "subcomponent of type LOCK_TYPE must have a codimension or "
2817 "be a subcomponent of a coarray. (Variables of type %s may "
2818 "not have a codimension as %s at %L has a codimension or a "
2819 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
2820 sym
->name
, c
->name
, &c
->loc
);
2822 /* Look for private components. */
2823 if (sym
->component_access
== ACCESS_PRIVATE
2824 || c
->attr
.access
== ACCESS_PRIVATE
2825 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
2826 sym
->attr
.private_comp
= 1;
2829 if (!seen_component
)
2830 sym
->attr
.zero_comp
= 1;
2836 /* Parse an ENUM. */
2844 int seen_enumerator
= 0;
2846 push_state (&s
, COMP_ENUM
, gfc_new_block
);
2850 while (compiling_enum
)
2852 st
= next_statement ();
2860 seen_enumerator
= 1;
2861 accept_statement (st
);
2866 if (!seen_enumerator
)
2867 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2868 accept_statement (st
);
2872 gfc_free_enum_history ();
2873 unexpected_statement (st
);
2881 /* Parse an interface. We must be able to deal with the possibility
2882 of recursive interfaces. The parse_spec() subroutine is mutually
2883 recursive with parse_interface(). */
2885 static gfc_statement
parse_spec (gfc_statement
);
2888 parse_interface (void)
2890 gfc_compile_state new_state
= COMP_NONE
, current_state
;
2891 gfc_symbol
*prog_unit
, *sym
;
2892 gfc_interface_info save
;
2893 gfc_state_data s1
, s2
;
2896 accept_statement (ST_INTERFACE
);
2898 current_interface
.ns
= gfc_current_ns
;
2899 save
= current_interface
;
2901 sym
= (current_interface
.type
== INTERFACE_GENERIC
2902 || current_interface
.type
== INTERFACE_USER_OP
)
2903 ? gfc_new_block
: NULL
;
2905 push_state (&s1
, COMP_INTERFACE
, sym
);
2906 current_state
= COMP_NONE
;
2909 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
2911 st
= next_statement ();
2919 if (st
== ST_SUBROUTINE
)
2920 new_state
= COMP_SUBROUTINE
;
2921 else if (st
== ST_FUNCTION
)
2922 new_state
= COMP_FUNCTION
;
2923 if (gfc_new_block
->attr
.pointer
)
2925 gfc_new_block
->attr
.pointer
= 0;
2926 gfc_new_block
->attr
.proc_pointer
= 1;
2928 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
2929 gfc_new_block
->formal
, NULL
))
2931 reject_statement ();
2932 gfc_free_namespace (gfc_current_ns
);
2938 case ST_MODULE_PROC
: /* The module procedure matcher makes
2939 sure the context is correct. */
2940 accept_statement (st
);
2941 gfc_free_namespace (gfc_current_ns
);
2944 case ST_END_INTERFACE
:
2945 gfc_free_namespace (gfc_current_ns
);
2946 gfc_current_ns
= current_interface
.ns
;
2950 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2951 gfc_ascii_statement (st
));
2952 reject_statement ();
2953 gfc_free_namespace (gfc_current_ns
);
2958 /* Make sure that the generic name has the right attribute. */
2959 if (current_interface
.type
== INTERFACE_GENERIC
2960 && current_state
== COMP_NONE
)
2962 if (new_state
== COMP_FUNCTION
&& sym
)
2963 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
2964 else if (new_state
== COMP_SUBROUTINE
&& sym
)
2965 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
2967 current_state
= new_state
;
2970 if (current_interface
.type
== INTERFACE_ABSTRACT
)
2972 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
2973 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
2974 gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
2975 "cannot be the same as an intrinsic type",
2976 gfc_new_block
->name
);
2979 push_state (&s2
, new_state
, gfc_new_block
);
2980 accept_statement (st
);
2981 prog_unit
= gfc_new_block
;
2982 prog_unit
->formal_ns
= gfc_current_ns
;
2983 if (prog_unit
== prog_unit
->formal_ns
->proc_name
2984 && prog_unit
->ns
!= prog_unit
->formal_ns
)
2988 /* Read data declaration statements. */
2989 st
= parse_spec (ST_NONE
);
2991 /* Since the interface block does not permit an IMPLICIT statement,
2992 the default type for the function or the result must be taken
2993 from the formal namespace. */
2994 if (new_state
== COMP_FUNCTION
)
2996 if (prog_unit
->result
== prog_unit
2997 && prog_unit
->ts
.type
== BT_UNKNOWN
)
2998 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
2999 else if (prog_unit
->result
!= prog_unit
3000 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
3001 gfc_set_default_type (prog_unit
->result
, 1,
3002 prog_unit
->formal_ns
);
3005 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
3007 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
3008 gfc_ascii_statement (st
));
3009 reject_statement ();
3013 /* Add EXTERNAL attribute to function or subroutine. */
3014 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
3015 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
3017 current_interface
= save
;
3018 gfc_add_interface (prog_unit
);
3021 if (current_interface
.ns
3022 && current_interface
.ns
->proc_name
3023 && strcmp (current_interface
.ns
->proc_name
->name
,
3024 prog_unit
->name
) == 0)
3025 gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
3026 "enclosing procedure", prog_unit
->name
,
3027 ¤t_interface
.ns
->proc_name
->declared_at
);
3036 /* Associate function characteristics by going back to the function
3037 declaration and rematching the prefix. */
3040 match_deferred_characteristics (gfc_typespec
* ts
)
3043 match m
= MATCH_ERROR
;
3044 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3046 loc
= gfc_current_locus
;
3048 gfc_current_locus
= gfc_current_block ()->declared_at
;
3051 gfc_buffer_error (true);
3052 m
= gfc_match_prefix (ts
);
3053 gfc_buffer_error (false);
3055 if (ts
->type
== BT_DERIVED
)
3063 /* Only permit one go at the characteristic association. */
3067 /* Set the function locus correctly. If we have not found the
3068 function name, there is an error. */
3070 && gfc_match ("function% %n", name
) == MATCH_YES
3071 && strcmp (name
, gfc_current_block ()->name
) == 0)
3073 gfc_current_block ()->declared_at
= gfc_current_locus
;
3074 gfc_commit_symbols ();
3079 gfc_undo_symbols ();
3082 gfc_current_locus
=loc
;
3087 /* Check specification-expressions in the function result of the currently
3088 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
3089 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
3090 scope are not yet parsed so this has to be delayed up to parse_spec. */
3093 check_function_result_typed (void)
3095 gfc_typespec
* ts
= &gfc_current_ns
->proc_name
->result
->ts
;
3097 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
3098 gcc_assert (ts
->type
!= BT_UNKNOWN
);
3100 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
3101 /* TODO: Extend when KIND type parameters are implemented. */
3102 if (ts
->type
== BT_CHARACTER
&& ts
->u
.cl
&& ts
->u
.cl
->length
)
3103 gfc_expr_check_typed (ts
->u
.cl
->length
, gfc_current_ns
, true);
3107 /* Parse a set of specification statements. Returns the statement
3108 that doesn't fit. */
3110 static gfc_statement
3111 parse_spec (gfc_statement st
)
3114 bool function_result_typed
= false;
3115 bool bad_characteristic
= false;
3118 verify_st_order (&ss
, ST_NONE
, false);
3120 st
= next_statement ();
3122 /* If we are not inside a function or don't have a result specified so far,
3123 do nothing special about it. */
3124 if (gfc_current_state () != COMP_FUNCTION
)
3125 function_result_typed
= true;
3128 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
3131 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
3132 function_result_typed
= true;
3137 /* If we're inside a BLOCK construct, some statements are disallowed.
3138 Check this here. Attribute declaration statements like INTENT, OPTIONAL
3139 or VALUE are also disallowed, but they don't have a particular ST_*
3140 key so we have to check for them individually in their matcher routine. */
3141 if (gfc_current_state () == COMP_BLOCK
)
3145 case ST_IMPLICIT_NONE
:
3148 case ST_EQUIVALENCE
:
3149 case ST_STATEMENT_FUNCTION
:
3150 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
3151 gfc_ascii_statement (st
));
3152 reject_statement ();
3158 else if (gfc_current_state () == COMP_BLOCK_DATA
)
3159 /* Fortran 2008, C1116. */
3166 case ST_END_BLOCK_DATA
:
3168 case ST_EQUIVALENCE
:
3171 case ST_IMPLICIT_NONE
:
3172 case ST_DERIVED_DECL
:
3180 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
3181 gfc_ascii_statement (st
));
3182 reject_statement ();
3186 /* If we find a statement that can not be followed by an IMPLICIT statement
3187 (and thus we can expect to see none any further), type the function result
3188 if it has not yet been typed. Be careful not to give the END statement
3189 to verify_st_order! */
3190 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
3192 bool verify_now
= false;
3194 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
3199 verify_st_order (&dummyss
, ST_NONE
, false);
3200 verify_st_order (&dummyss
, st
, false);
3202 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
3208 check_function_result_typed ();
3209 function_result_typed
= true;
3218 case ST_IMPLICIT_NONE
:
3220 if (!function_result_typed
)
3222 check_function_result_typed ();
3223 function_result_typed
= true;
3229 case ST_DATA
: /* Not allowed in interfaces */
3230 if (gfc_current_state () == COMP_INTERFACE
)
3240 case ST_DERIVED_DECL
:
3243 if (!verify_st_order (&ss
, st
, false))
3245 reject_statement ();
3246 st
= next_statement ();
3256 case ST_DERIVED_DECL
:
3262 if (gfc_current_state () != COMP_MODULE
)
3264 gfc_error ("%s statement must appear in a MODULE",
3265 gfc_ascii_statement (st
));
3266 reject_statement ();
3270 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
3272 gfc_error ("%s statement at %C follows another accessibility "
3273 "specification", gfc_ascii_statement (st
));
3274 reject_statement ();
3278 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
3279 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3283 case ST_STATEMENT_FUNCTION
:
3284 if (gfc_current_state () == COMP_MODULE
)
3286 unexpected_statement (st
);
3294 accept_statement (st
);
3295 st
= next_statement ();
3299 accept_statement (st
);
3301 st
= next_statement ();
3304 case ST_GET_FCN_CHARACTERISTICS
:
3305 /* This statement triggers the association of a function's result
3307 ts
= &gfc_current_block ()->result
->ts
;
3308 if (match_deferred_characteristics (ts
) != MATCH_YES
)
3309 bad_characteristic
= true;
3311 st
= next_statement ();
3314 case ST_OACC_DECLARE
:
3315 if (!verify_st_order(&ss
, st
, false))
3317 reject_statement ();
3318 st
= next_statement ();
3321 if (gfc_state_stack
->ext
.oacc_declare_clauses
== NULL
)
3322 gfc_state_stack
->ext
.oacc_declare_clauses
= new_st
.ext
.omp_clauses
;
3323 accept_statement (st
);
3324 st
= next_statement ();
3331 /* If match_deferred_characteristics failed, then there is an error. */
3332 if (bad_characteristic
)
3334 ts
= &gfc_current_block ()->result
->ts
;
3335 if (ts
->type
!= BT_DERIVED
)
3336 gfc_error ("Bad kind expression for function %qs at %L",
3337 gfc_current_block ()->name
,
3338 &gfc_current_block ()->declared_at
);
3340 gfc_error ("The type for function %qs at %L is not accessible",
3341 gfc_current_block ()->name
,
3342 &gfc_current_block ()->declared_at
);
3344 gfc_current_block ()->ts
.kind
= 0;
3345 /* Keep the derived type; if it's bad, it will be discovered later. */
3346 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
3347 ts
->type
= BT_UNKNOWN
;
3354 /* Parse a WHERE block, (not a simple WHERE statement). */
3357 parse_where_block (void)
3359 int seen_empty_else
;
3364 accept_statement (ST_WHERE_BLOCK
);
3365 top
= gfc_state_stack
->tail
;
3367 push_state (&s
, COMP_WHERE
, gfc_new_block
);
3369 d
= add_statement ();
3370 d
->expr1
= top
->expr1
;
3376 seen_empty_else
= 0;
3380 st
= next_statement ();
3386 case ST_WHERE_BLOCK
:
3387 parse_where_block ();
3392 accept_statement (st
);
3396 if (seen_empty_else
)
3398 gfc_error ("ELSEWHERE statement at %C follows previous "
3399 "unmasked ELSEWHERE");
3400 reject_statement ();
3404 if (new_st
.expr1
== NULL
)
3405 seen_empty_else
= 1;
3407 d
= new_level (gfc_state_stack
->head
);
3409 d
->expr1
= new_st
.expr1
;
3411 accept_statement (st
);
3416 accept_statement (st
);
3420 gfc_error ("Unexpected %s statement in WHERE block at %C",
3421 gfc_ascii_statement (st
));
3422 reject_statement ();
3426 while (st
!= ST_END_WHERE
);
3432 /* Parse a FORALL block (not a simple FORALL statement). */
3435 parse_forall_block (void)
3441 accept_statement (ST_FORALL_BLOCK
);
3442 top
= gfc_state_stack
->tail
;
3444 push_state (&s
, COMP_FORALL
, gfc_new_block
);
3446 d
= add_statement ();
3447 d
->op
= EXEC_FORALL
;
3452 st
= next_statement ();
3457 case ST_POINTER_ASSIGNMENT
:
3460 accept_statement (st
);
3463 case ST_WHERE_BLOCK
:
3464 parse_where_block ();
3467 case ST_FORALL_BLOCK
:
3468 parse_forall_block ();
3472 accept_statement (st
);
3479 gfc_error ("Unexpected %s statement in FORALL block at %C",
3480 gfc_ascii_statement (st
));
3482 reject_statement ();
3486 while (st
!= ST_END_FORALL
);
3492 static gfc_statement
parse_executable (gfc_statement
);
3494 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
3497 parse_if_block (void)
3506 accept_statement (ST_IF_BLOCK
);
3508 top
= gfc_state_stack
->tail
;
3509 push_state (&s
, COMP_IF
, gfc_new_block
);
3511 new_st
.op
= EXEC_IF
;
3512 d
= add_statement ();
3514 d
->expr1
= top
->expr1
;
3520 st
= parse_executable (ST_NONE
);
3530 gfc_error_1 ("ELSE IF statement at %C cannot follow ELSE "
3531 "statement at %L", &else_locus
);
3533 reject_statement ();
3537 d
= new_level (gfc_state_stack
->head
);
3539 d
->expr1
= new_st
.expr1
;
3541 accept_statement (st
);
3548 gfc_error ("Duplicate ELSE statements at %L and %C",
3550 reject_statement ();
3555 else_locus
= gfc_current_locus
;
3557 d
= new_level (gfc_state_stack
->head
);
3560 accept_statement (st
);
3568 unexpected_statement (st
);
3572 while (st
!= ST_ENDIF
);
3575 accept_statement (st
);
3579 /* Parse a SELECT block. */
3582 parse_select_block (void)
3588 accept_statement (ST_SELECT_CASE
);
3590 cp
= gfc_state_stack
->tail
;
3591 push_state (&s
, COMP_SELECT
, gfc_new_block
);
3593 /* Make sure that the next statement is a CASE or END SELECT. */
3596 st
= next_statement ();
3599 if (st
== ST_END_SELECT
)
3601 /* Empty SELECT CASE is OK. */
3602 accept_statement (st
);
3609 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
3612 reject_statement ();
3615 /* At this point, we're got a nonempty select block. */
3616 cp
= new_level (cp
);
3619 accept_statement (st
);
3623 st
= parse_executable (ST_NONE
);
3630 cp
= new_level (gfc_state_stack
->head
);
3632 gfc_clear_new_st ();
3634 accept_statement (st
);
3640 /* Can't have an executable statement because of
3641 parse_executable(). */
3643 unexpected_statement (st
);
3647 while (st
!= ST_END_SELECT
);
3650 accept_statement (st
);
3654 /* Pop the current selector from the SELECT TYPE stack. */
3657 select_type_pop (void)
3659 gfc_select_type_stack
*old
= select_type_stack
;
3660 select_type_stack
= old
->prev
;
3665 /* Parse a SELECT TYPE construct (F03:R821). */
3668 parse_select_type_block (void)
3674 accept_statement (ST_SELECT_TYPE
);
3676 cp
= gfc_state_stack
->tail
;
3677 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
3679 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
3683 st
= next_statement ();
3686 if (st
== ST_END_SELECT
)
3687 /* Empty SELECT CASE is OK. */
3689 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
3692 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
3693 "following SELECT TYPE at %C");
3695 reject_statement ();
3698 /* At this point, we're got a nonempty select block. */
3699 cp
= new_level (cp
);
3702 accept_statement (st
);
3706 st
= parse_executable (ST_NONE
);
3714 cp
= new_level (gfc_state_stack
->head
);
3716 gfc_clear_new_st ();
3718 accept_statement (st
);
3724 /* Can't have an executable statement because of
3725 parse_executable(). */
3727 unexpected_statement (st
);
3731 while (st
!= ST_END_SELECT
);
3735 accept_statement (st
);
3736 gfc_current_ns
= gfc_current_ns
->parent
;
3741 /* Given a symbol, make sure it is not an iteration variable for a DO
3742 statement. This subroutine is called when the symbol is seen in a
3743 context that causes it to become redefined. If the symbol is an
3744 iterator, we generate an error message and return nonzero. */
3747 gfc_check_do_variable (gfc_symtree
*st
)
3751 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
3752 if (s
->do_variable
== st
)
3754 gfc_error_now_1 ("Variable '%s' at %C cannot be redefined inside "
3755 "loop beginning at %L", st
->name
, &s
->head
->loc
);
3763 /* Checks to see if the current statement label closes an enddo.
3764 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3765 an error) if it incorrectly closes an ENDDO. */
3768 check_do_closure (void)
3772 if (gfc_statement_label
== NULL
)
3775 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
3776 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
3780 return 0; /* No loops to close */
3782 if (p
->ext
.end_do_label
== gfc_statement_label
)
3784 if (p
== gfc_state_stack
)
3787 gfc_error ("End of nonblock DO statement at %C is within another block");
3791 /* At this point, the label doesn't terminate the innermost loop.
3792 Make sure it doesn't terminate another one. */
3793 for (; p
; p
= p
->previous
)
3794 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
3795 && p
->ext
.end_do_label
== gfc_statement_label
)
3797 gfc_error ("End of nonblock DO statement at %C is interwoven "
3798 "with another DO loop");
3806 /* Parse a series of contained program units. */
3808 static void parse_progunit (gfc_statement
);
3811 /* Parse a CRITICAL block. */
3814 parse_critical_block (void)
3817 gfc_state_data s
, *sd
;
3820 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
3821 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
3822 gfc_error_now (is_oacc (sd
)
3823 ? "CRITICAL block inside of OpenACC region at %C"
3824 : "CRITICAL block inside of OpenMP region at %C");
3826 s
.ext
.end_do_label
= new_st
.label1
;
3828 accept_statement (ST_CRITICAL
);
3829 top
= gfc_state_stack
->tail
;
3831 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
3833 d
= add_statement ();
3834 d
->op
= EXEC_CRITICAL
;
3839 st
= parse_executable (ST_NONE
);
3847 case ST_END_CRITICAL
:
3848 if (s
.ext
.end_do_label
!= NULL
3849 && s
.ext
.end_do_label
!= gfc_statement_label
)
3850 gfc_error_now ("Statement label in END CRITICAL at %C does not "
3851 "match CRITICAL label");
3853 if (gfc_statement_label
!= NULL
)
3855 new_st
.op
= EXEC_NOP
;
3861 unexpected_statement (st
);
3865 while (st
!= ST_END_CRITICAL
);
3868 accept_statement (st
);
3872 /* Set up the local namespace for a BLOCK construct. */
3875 gfc_build_block_ns (gfc_namespace
*parent_ns
)
3877 gfc_namespace
* my_ns
;
3878 static int numblock
= 1;
3880 my_ns
= gfc_get_namespace (parent_ns
, 1);
3881 my_ns
->construct_entities
= 1;
3883 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3884 code generation (so it must not be NULL).
3885 We set its recursive argument if our container procedure is recursive, so
3886 that local variables are accordingly placed on the stack when it
3887 will be necessary. */
3889 my_ns
->proc_name
= gfc_new_block
;
3893 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
3895 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
3896 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
3897 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
3898 my_ns
->proc_name
->name
, NULL
);
3900 gfc_commit_symbol (my_ns
->proc_name
);
3903 if (parent_ns
->proc_name
)
3904 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
3910 /* Parse a BLOCK construct. */
3913 parse_block_construct (void)
3915 gfc_namespace
* my_ns
;
3918 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
3920 my_ns
= gfc_build_block_ns (gfc_current_ns
);
3922 new_st
.op
= EXEC_BLOCK
;
3923 new_st
.ext
.block
.ns
= my_ns
;
3924 new_st
.ext
.block
.assoc
= NULL
;
3925 accept_statement (ST_BLOCK
);
3927 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
3928 gfc_current_ns
= my_ns
;
3930 parse_progunit (ST_NONE
);
3932 gfc_current_ns
= gfc_current_ns
->parent
;
3937 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
3938 behind the scenes with compiler-generated variables. */
3941 parse_associate (void)
3943 gfc_namespace
* my_ns
;
3946 gfc_association_list
* a
;
3948 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
3950 my_ns
= gfc_build_block_ns (gfc_current_ns
);
3952 new_st
.op
= EXEC_BLOCK
;
3953 new_st
.ext
.block
.ns
= my_ns
;
3954 gcc_assert (new_st
.ext
.block
.assoc
);
3956 /* Add all associate-names as BLOCK variables. Creating them is enough
3957 for now, they'll get their values during trans-* phase. */
3958 gfc_current_ns
= my_ns
;
3959 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
3963 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
3967 sym
->attr
.flavor
= FL_VARIABLE
;
3969 sym
->declared_at
= a
->where
;
3970 gfc_set_sym_referenced (sym
);
3972 /* Initialize the typespec. It is not available in all cases,
3973 however, as it may only be set on the target during resolution.
3974 Still, sometimes it helps to have it right now -- especially
3975 for parsing component references on the associate-name
3976 in case of association to a derived-type. */
3977 sym
->ts
= a
->target
->ts
;
3980 accept_statement (ST_ASSOCIATE
);
3981 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
3984 st
= parse_executable (ST_NONE
);
3991 accept_statement (st
);
3992 my_ns
->code
= gfc_state_stack
->head
;
3996 unexpected_statement (st
);
4000 gfc_current_ns
= gfc_current_ns
->parent
;
4005 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
4006 handled inside of parse_executable(), because they aren't really
4010 parse_do_block (void)
4019 s
.ext
.end_do_label
= new_st
.label1
;
4021 if (new_st
.ext
.iterator
!= NULL
)
4022 stree
= new_st
.ext
.iterator
->var
->symtree
;
4026 accept_statement (ST_DO
);
4028 top
= gfc_state_stack
->tail
;
4029 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
4032 s
.do_variable
= stree
;
4034 top
->block
= new_level (top
);
4035 top
->block
->op
= EXEC_DO
;
4038 st
= parse_executable (ST_NONE
);
4046 if (s
.ext
.end_do_label
!= NULL
4047 && s
.ext
.end_do_label
!= gfc_statement_label
)
4048 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
4051 if (gfc_statement_label
!= NULL
)
4053 new_st
.op
= EXEC_NOP
;
4058 case ST_IMPLIED_ENDDO
:
4059 /* If the do-stmt of this DO construct has a do-construct-name,
4060 the corresponding end-do must be an end-do-stmt (with a matching
4061 name, but in that case we must have seen ST_ENDDO first).
4062 We only complain about this in pedantic mode. */
4063 if (gfc_current_block () != NULL
)
4064 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
4065 &gfc_current_block()->declared_at
);
4070 unexpected_statement (st
);
4075 accept_statement (st
);
4079 /* Parse the statements of OpenMP do/parallel do. */
4081 static gfc_statement
4082 parse_omp_do (gfc_statement omp_st
)
4088 accept_statement (omp_st
);
4090 cp
= gfc_state_stack
->tail
;
4091 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4092 np
= new_level (cp
);
4098 st
= next_statement ();
4101 else if (st
== ST_DO
)
4104 unexpected_statement (st
);
4108 if (gfc_statement_label
!= NULL
4109 && gfc_state_stack
->previous
!= NULL
4110 && gfc_state_stack
->previous
->state
== COMP_DO
4111 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4119 there should be no !$OMP END DO. */
4121 return ST_IMPLIED_ENDDO
;
4124 check_do_closure ();
4127 st
= next_statement ();
4128 gfc_statement omp_end_st
= ST_OMP_END_DO
;
4131 case ST_OMP_DISTRIBUTE
: omp_end_st
= ST_OMP_END_DISTRIBUTE
; break;
4132 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4133 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4135 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4136 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4138 case ST_OMP_DISTRIBUTE_SIMD
:
4139 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4141 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
4142 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
4143 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
4144 case ST_OMP_PARALLEL_DO_SIMD
:
4145 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
4147 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
4148 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4149 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4151 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4152 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4154 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4155 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4157 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4158 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4160 case ST_OMP_TEAMS_DISTRIBUTE
:
4161 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4163 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4164 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4166 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4167 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4169 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4170 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4172 default: gcc_unreachable ();
4174 if (st
== omp_end_st
)
4176 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
4177 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4179 gcc_assert (new_st
.op
== EXEC_NOP
);
4180 gfc_clear_new_st ();
4181 gfc_commit_symbols ();
4182 gfc_warning_check ();
4183 st
= next_statement ();
4189 /* Parse the statements of OpenMP atomic directive. */
4191 static gfc_statement
4192 parse_omp_atomic (void)
4199 accept_statement (ST_OMP_ATOMIC
);
4201 cp
= gfc_state_stack
->tail
;
4202 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4203 np
= new_level (cp
);
4206 count
= 1 + ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4207 == GFC_OMP_ATOMIC_CAPTURE
);
4211 st
= next_statement ();
4214 else if (st
== ST_ASSIGNMENT
)
4216 accept_statement (st
);
4220 unexpected_statement (st
);
4225 st
= next_statement ();
4226 if (st
== ST_OMP_END_ATOMIC
)
4228 gfc_clear_new_st ();
4229 gfc_commit_symbols ();
4230 gfc_warning_check ();
4231 st
= next_statement ();
4233 else if ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4234 == GFC_OMP_ATOMIC_CAPTURE
)
4235 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
4240 /* Parse the statements of an OpenACC structured block. */
4243 parse_oacc_structured_block (gfc_statement acc_st
)
4245 gfc_statement st
, acc_end_st
;
4247 gfc_state_data s
, *sd
;
4249 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4250 if (sd
->state
== COMP_CRITICAL
)
4251 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4253 accept_statement (acc_st
);
4255 cp
= gfc_state_stack
->tail
;
4256 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4257 np
= new_level (cp
);
4262 case ST_OACC_PARALLEL
:
4263 acc_end_st
= ST_OACC_END_PARALLEL
;
4265 case ST_OACC_KERNELS
:
4266 acc_end_st
= ST_OACC_END_KERNELS
;
4269 acc_end_st
= ST_OACC_END_DATA
;
4271 case ST_OACC_HOST_DATA
:
4272 acc_end_st
= ST_OACC_END_HOST_DATA
;
4280 st
= parse_executable (ST_NONE
);
4283 else if (st
!= acc_end_st
)
4284 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
4285 reject_statement ();
4287 while (st
!= acc_end_st
);
4289 gcc_assert (new_st
.op
== EXEC_NOP
);
4291 gfc_clear_new_st ();
4292 gfc_commit_symbols ();
4293 gfc_warning_check ();
4297 /* Parse the statements of OpenACC loop/parallel loop/kernels loop. */
4299 static gfc_statement
4300 parse_oacc_loop (gfc_statement acc_st
)
4304 gfc_state_data s
, *sd
;
4306 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4307 if (sd
->state
== COMP_CRITICAL
)
4308 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4310 accept_statement (acc_st
);
4312 cp
= gfc_state_stack
->tail
;
4313 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4314 np
= new_level (cp
);
4320 st
= next_statement ();
4323 else if (st
== ST_DO
)
4327 gfc_error ("Expected DO loop at %C");
4328 reject_statement ();
4333 if (gfc_statement_label
!= NULL
4334 && gfc_state_stack
->previous
!= NULL
4335 && gfc_state_stack
->previous
->state
== COMP_DO
4336 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4339 return ST_IMPLIED_ENDDO
;
4342 check_do_closure ();
4345 st
= next_statement ();
4346 if (st
== ST_OACC_END_LOOP
)
4347 gfc_warning (0, "Redundant !$ACC END LOOP at %C");
4348 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
4349 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
4350 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
4352 gcc_assert (new_st
.op
== EXEC_NOP
);
4353 gfc_clear_new_st ();
4354 gfc_commit_symbols ();
4355 gfc_warning_check ();
4356 st
= next_statement ();
4362 /* Parse the statements of an OpenMP structured block. */
4365 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
4367 gfc_statement st
, omp_end_st
;
4371 accept_statement (omp_st
);
4373 cp
= gfc_state_stack
->tail
;
4374 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4375 np
= new_level (cp
);
4381 case ST_OMP_PARALLEL
:
4382 omp_end_st
= ST_OMP_END_PARALLEL
;
4384 case ST_OMP_PARALLEL_SECTIONS
:
4385 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
4387 case ST_OMP_SECTIONS
:
4388 omp_end_st
= ST_OMP_END_SECTIONS
;
4390 case ST_OMP_ORDERED
:
4391 omp_end_st
= ST_OMP_END_ORDERED
;
4393 case ST_OMP_CRITICAL
:
4394 omp_end_st
= ST_OMP_END_CRITICAL
;
4397 omp_end_st
= ST_OMP_END_MASTER
;
4400 omp_end_st
= ST_OMP_END_SINGLE
;
4403 omp_end_st
= ST_OMP_END_TARGET
;
4405 case ST_OMP_TARGET_DATA
:
4406 omp_end_st
= ST_OMP_END_TARGET_DATA
;
4408 case ST_OMP_TARGET_TEAMS
:
4409 omp_end_st
= ST_OMP_END_TARGET_TEAMS
;
4411 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4412 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4414 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4415 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4417 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4418 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4420 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4421 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4424 omp_end_st
= ST_OMP_END_TASK
;
4426 case ST_OMP_TASKGROUP
:
4427 omp_end_st
= ST_OMP_END_TASKGROUP
;
4430 omp_end_st
= ST_OMP_END_TEAMS
;
4432 case ST_OMP_TEAMS_DISTRIBUTE
:
4433 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4435 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4436 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4438 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4439 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4441 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4442 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4444 case ST_OMP_DISTRIBUTE
:
4445 omp_end_st
= ST_OMP_END_DISTRIBUTE
;
4447 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4448 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4450 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4451 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4453 case ST_OMP_DISTRIBUTE_SIMD
:
4454 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4456 case ST_OMP_WORKSHARE
:
4457 omp_end_st
= ST_OMP_END_WORKSHARE
;
4459 case ST_OMP_PARALLEL_WORKSHARE
:
4460 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
4468 if (workshare_stmts_only
)
4470 /* Inside of !$omp workshare, only
4473 where statements and constructs
4474 forall statements and constructs
4478 are allowed. For !$omp critical these
4479 restrictions apply recursively. */
4482 st
= next_statement ();
4493 accept_statement (st
);
4496 case ST_WHERE_BLOCK
:
4497 parse_where_block ();
4500 case ST_FORALL_BLOCK
:
4501 parse_forall_block ();
4504 case ST_OMP_PARALLEL
:
4505 case ST_OMP_PARALLEL_SECTIONS
:
4506 parse_omp_structured_block (st
, false);
4509 case ST_OMP_PARALLEL_WORKSHARE
:
4510 case ST_OMP_CRITICAL
:
4511 parse_omp_structured_block (st
, true);
4514 case ST_OMP_PARALLEL_DO
:
4515 case ST_OMP_PARALLEL_DO_SIMD
:
4516 st
= parse_omp_do (st
);
4520 st
= parse_omp_atomic ();
4531 st
= next_statement ();
4535 st
= parse_executable (ST_NONE
);
4538 else if (st
== ST_OMP_SECTION
4539 && (omp_st
== ST_OMP_SECTIONS
4540 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
4542 np
= new_level (np
);
4546 else if (st
!= omp_end_st
)
4547 unexpected_statement (st
);
4549 while (st
!= omp_end_st
);
4553 case EXEC_OMP_END_NOWAIT
:
4554 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4556 case EXEC_OMP_CRITICAL
:
4557 if (((cp
->ext
.omp_name
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
4558 || (new_st
.ext
.omp_name
!= NULL
4559 && strcmp (cp
->ext
.omp_name
, new_st
.ext
.omp_name
) != 0))
4560 gfc_error ("Name after !$omp critical and !$omp end critical does "
4562 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
4564 case EXEC_OMP_END_SINGLE
:
4565 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
4566 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
4567 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
4568 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
4576 gfc_clear_new_st ();
4577 gfc_commit_symbols ();
4578 gfc_warning_check ();
4583 /* Accept a series of executable statements. We return the first
4584 statement that doesn't fit to the caller. Any block statements are
4585 passed on to the correct handler, which usually passes the buck
4588 static gfc_statement
4589 parse_executable (gfc_statement st
)
4594 st
= next_statement ();
4598 close_flag
= check_do_closure ();
4603 case ST_END_PROGRAM
:
4606 case ST_END_FUNCTION
:
4611 case ST_END_SUBROUTINE
:
4616 case ST_SELECT_CASE
:
4617 gfc_error ("%s statement at %C cannot terminate a non-block "
4618 "DO loop", gfc_ascii_statement (st
));
4631 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
4632 "first executable statement");
4638 accept_statement (st
);
4639 if (close_flag
== 1)
4640 return ST_IMPLIED_ENDDO
;
4644 parse_block_construct ();
4655 case ST_SELECT_CASE
:
4656 parse_select_block ();
4659 case ST_SELECT_TYPE
:
4660 parse_select_type_block();
4665 if (check_do_closure () == 1)
4666 return ST_IMPLIED_ENDDO
;
4670 parse_critical_block ();
4673 case ST_WHERE_BLOCK
:
4674 parse_where_block ();
4677 case ST_FORALL_BLOCK
:
4678 parse_forall_block ();
4681 case ST_OACC_PARALLEL_LOOP
:
4682 case ST_OACC_KERNELS_LOOP
:
4684 st
= parse_oacc_loop (st
);
4685 if (st
== ST_IMPLIED_ENDDO
)
4689 case ST_OACC_PARALLEL
:
4690 case ST_OACC_KERNELS
:
4692 case ST_OACC_HOST_DATA
:
4693 parse_oacc_structured_block (st
);
4696 case ST_OMP_PARALLEL
:
4697 case ST_OMP_PARALLEL_SECTIONS
:
4698 case ST_OMP_SECTIONS
:
4699 case ST_OMP_ORDERED
:
4700 case ST_OMP_CRITICAL
:
4704 case ST_OMP_TARGET_DATA
:
4705 case ST_OMP_TARGET_TEAMS
:
4708 case ST_OMP_TASKGROUP
:
4709 parse_omp_structured_block (st
, false);
4712 case ST_OMP_WORKSHARE
:
4713 case ST_OMP_PARALLEL_WORKSHARE
:
4714 parse_omp_structured_block (st
, true);
4717 case ST_OMP_DISTRIBUTE
:
4718 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4719 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4720 case ST_OMP_DISTRIBUTE_SIMD
:
4722 case ST_OMP_DO_SIMD
:
4723 case ST_OMP_PARALLEL_DO
:
4724 case ST_OMP_PARALLEL_DO_SIMD
:
4726 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4727 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4728 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4729 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4730 case ST_OMP_TEAMS_DISTRIBUTE
:
4731 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4732 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4733 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4734 st
= parse_omp_do (st
);
4735 if (st
== ST_IMPLIED_ENDDO
)
4740 st
= parse_omp_atomic ();
4747 st
= next_statement ();
4752 /* Fix the symbols for sibling functions. These are incorrectly added to
4753 the child namespace as the parser didn't know about this procedure. */
4756 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
4760 gfc_symbol
*old_sym
;
4762 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
4764 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
4766 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
4767 goto fixup_contained
;
4769 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
4770 && sym
->attr
.generic
&& sym
->attr
.function
)
4771 ||(sym
->attr
.flavor
== FL_DERIVED
4772 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
4773 goto fixup_contained
;
4775 old_sym
= st
->n
.sym
;
4776 if (old_sym
->ns
== ns
4777 && !old_sym
->attr
.contained
4779 /* By 14.6.1.3, host association should be excluded
4780 for the following. */
4781 && !(old_sym
->attr
.external
4782 || (old_sym
->ts
.type
!= BT_UNKNOWN
4783 && !old_sym
->attr
.implicit_type
)
4784 || old_sym
->attr
.flavor
== FL_PARAMETER
4785 || old_sym
->attr
.use_assoc
4786 || old_sym
->attr
.in_common
4787 || old_sym
->attr
.in_equivalence
4788 || old_sym
->attr
.data
4789 || old_sym
->attr
.dummy
4790 || old_sym
->attr
.result
4791 || old_sym
->attr
.dimension
4792 || old_sym
->attr
.allocatable
4793 || old_sym
->attr
.intrinsic
4794 || old_sym
->attr
.generic
4795 || old_sym
->attr
.flavor
== FL_NAMELIST
4796 || old_sym
->attr
.flavor
== FL_LABEL
4797 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
4799 /* Replace it with the symbol from the parent namespace. */
4803 gfc_release_symbol (old_sym
);
4807 /* Do the same for any contained procedures. */
4808 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
4813 parse_contained (int module
)
4815 gfc_namespace
*ns
, *parent_ns
, *tmp
;
4816 gfc_state_data s1
, s2
;
4820 int contains_statements
= 0;
4823 push_state (&s1
, COMP_CONTAINS
, NULL
);
4824 parent_ns
= gfc_current_ns
;
4828 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
4830 gfc_current_ns
->sibling
= parent_ns
->contained
;
4831 parent_ns
->contained
= gfc_current_ns
;
4834 /* Process the next available statement. We come here if we got an error
4835 and rejected the last statement. */
4836 st
= next_statement ();
4845 contains_statements
= 1;
4846 accept_statement (st
);
4849 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
4852 /* For internal procedures, create/update the symbol in the
4853 parent namespace. */
4857 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
4858 gfc_error ("Contained procedure %qs at %C is already "
4859 "ambiguous", gfc_new_block
->name
);
4862 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
4864 &gfc_new_block
->declared_at
))
4866 if (st
== ST_FUNCTION
)
4867 gfc_add_function (&sym
->attr
, sym
->name
,
4868 &gfc_new_block
->declared_at
);
4870 gfc_add_subroutine (&sym
->attr
, sym
->name
,
4871 &gfc_new_block
->declared_at
);
4875 gfc_commit_symbols ();
4878 sym
= gfc_new_block
;
4880 /* Mark this as a contained function, so it isn't replaced
4881 by other module functions. */
4882 sym
->attr
.contained
= 1;
4884 /* Set implicit_pure so that it can be reset if any of the
4885 tests for purity fail. This is used for some optimisation
4886 during translation. */
4887 if (!sym
->attr
.pure
)
4888 sym
->attr
.implicit_pure
= 1;
4890 parse_progunit (ST_NONE
);
4892 /* Fix up any sibling functions that refer to this one. */
4893 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
4894 /* Or refer to any of its alternate entry points. */
4895 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
4896 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
4898 gfc_current_ns
->code
= s2
.head
;
4899 gfc_current_ns
= parent_ns
;
4904 /* These statements are associated with the end of the host unit. */
4905 case ST_END_FUNCTION
:
4907 case ST_END_PROGRAM
:
4908 case ST_END_SUBROUTINE
:
4909 accept_statement (st
);
4910 gfc_current_ns
->code
= s1
.head
;
4914 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
4915 gfc_ascii_statement (st
));
4916 reject_statement ();
4922 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
4923 && st
!= ST_END_MODULE
&& st
!= ST_END_PROGRAM
);
4925 /* The first namespace in the list is guaranteed to not have
4926 anything (worthwhile) in it. */
4927 tmp
= gfc_current_ns
;
4928 gfc_current_ns
= parent_ns
;
4929 if (seen_error
&& tmp
->refs
> 1)
4930 gfc_free_namespace (tmp
);
4932 ns
= gfc_current_ns
->contained
;
4933 gfc_current_ns
->contained
= ns
->sibling
;
4934 gfc_free_namespace (ns
);
4937 if (!contains_statements
)
4938 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
4939 "FUNCTION or SUBROUTINE statement at %C");
4943 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
4946 parse_progunit (gfc_statement st
)
4951 st
= parse_spec (st
);
4958 /* This is not allowed within BLOCK! */
4959 if (gfc_current_state () != COMP_BLOCK
)
4964 accept_statement (st
);
4971 if (gfc_current_state () == COMP_FUNCTION
)
4972 gfc_check_function_type (gfc_current_ns
);
4977 st
= parse_executable (st
);
4985 /* This is not allowed within BLOCK! */
4986 if (gfc_current_state () != COMP_BLOCK
)
4991 accept_statement (st
);
4998 unexpected_statement (st
);
4999 reject_statement ();
5000 st
= next_statement ();
5006 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
5007 if (p
->state
== COMP_CONTAINS
)
5010 if (gfc_find_state (COMP_MODULE
) == true)
5015 gfc_error ("CONTAINS statement at %C is already in a contained "
5017 reject_statement ();
5018 st
= next_statement ();
5022 parse_contained (0);
5025 gfc_current_ns
->code
= gfc_state_stack
->head
;
5026 if (gfc_state_stack
->state
== COMP_PROGRAM
5027 || gfc_state_stack
->state
== COMP_MODULE
5028 || gfc_state_stack
->state
== COMP_SUBROUTINE
5029 || gfc_state_stack
->state
== COMP_FUNCTION
5030 || gfc_state_stack
->state
== COMP_BLOCK
)
5031 gfc_current_ns
->oacc_declare_clauses
5032 = gfc_state_stack
->ext
.oacc_declare_clauses
;
5036 /* Come here to complain about a global symbol already in use as
5040 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
5045 where
= &gfc_current_locus
;
5055 case GSYM_SUBROUTINE
:
5056 name
= "SUBROUTINE";
5061 case GSYM_BLOCK_DATA
:
5062 name
= "BLOCK DATA";
5068 gfc_internal_error ("gfc_global_used(): Bad type");
5072 if (sym
->binding_label
)
5073 gfc_error_1 ("Global binding name '%s' at %L is already being used as a %s "
5074 "at %L", sym
->binding_label
, where
, name
, &sym
->where
);
5076 gfc_error_1 ("Global name '%s' at %L is already being used as a %s at %L",
5077 sym
->name
, where
, name
, &sym
->where
);
5081 /* Parse a block data program unit. */
5084 parse_block_data (void)
5087 static locus blank_locus
;
5088 static int blank_block
=0;
5091 gfc_current_ns
->proc_name
= gfc_new_block
;
5092 gfc_current_ns
->is_block_data
= 1;
5094 if (gfc_new_block
== NULL
)
5097 gfc_error ("Blank BLOCK DATA at %C conflicts with "
5098 "prior BLOCK DATA at %L", &blank_locus
);
5102 blank_locus
= gfc_current_locus
;
5107 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5109 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
5110 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5113 s
->type
= GSYM_BLOCK_DATA
;
5114 s
->where
= gfc_new_block
->declared_at
;
5119 st
= parse_spec (ST_NONE
);
5121 while (st
!= ST_END_BLOCK_DATA
)
5123 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
5124 gfc_ascii_statement (st
));
5125 reject_statement ();
5126 st
= next_statement ();
5131 /* Parse a module subprogram. */
5140 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5141 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
5142 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5145 s
->type
= GSYM_MODULE
;
5146 s
->where
= gfc_new_block
->declared_at
;
5150 st
= parse_spec (ST_NONE
);
5160 parse_contained (1);
5164 accept_statement (st
);
5168 gfc_error ("Unexpected %s statement in MODULE at %C",
5169 gfc_ascii_statement (st
));
5172 reject_statement ();
5173 st
= next_statement ();
5177 /* Make sure not to free the namespace twice on error. */
5179 s
->ns
= gfc_current_ns
;
5183 /* Add a procedure name to the global symbol table. */
5186 add_global_procedure (bool sub
)
5190 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5191 name is a global identifier. */
5192 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5194 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5197 || (s
->type
!= GSYM_UNKNOWN
5198 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5200 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5201 /* Silence follow-up errors. */
5202 gfc_new_block
->binding_label
= NULL
;
5206 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5207 s
->sym_name
= gfc_new_block
->name
;
5208 s
->where
= gfc_new_block
->declared_at
;
5210 s
->ns
= gfc_current_ns
;
5214 /* Don't add the symbol multiple times. */
5215 if (gfc_new_block
->binding_label
5216 && (!gfc_notification_std (GFC_STD_F2008
)
5217 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
5219 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
);
5222 || (s
->type
!= GSYM_UNKNOWN
5223 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5225 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5226 /* Silence follow-up errors. */
5227 gfc_new_block
->binding_label
= NULL
;
5231 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5232 s
->sym_name
= gfc_new_block
->name
;
5233 s
->binding_label
= gfc_new_block
->binding_label
;
5234 s
->where
= gfc_new_block
->declared_at
;
5236 s
->ns
= gfc_current_ns
;
5242 /* Add a program to the global symbol table. */
5245 add_global_program (void)
5249 if (gfc_new_block
== NULL
)
5251 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5253 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
5254 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5257 s
->type
= GSYM_PROGRAM
;
5258 s
->where
= gfc_new_block
->declared_at
;
5260 s
->ns
= gfc_current_ns
;
5265 /* Resolve all the program units. */
5267 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
5269 gfc_free_dt_list ();
5270 gfc_current_ns
= gfc_global_ns_list
;
5271 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5273 if (gfc_current_ns
->proc_name
5274 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5275 continue; /* Already resolved. */
5277 if (gfc_current_ns
->proc_name
)
5278 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5279 gfc_resolve (gfc_current_ns
);
5280 gfc_current_ns
->derived_types
= gfc_derived_types
;
5281 gfc_derived_types
= NULL
;
5287 clean_up_modules (gfc_gsymbol
*gsym
)
5292 clean_up_modules (gsym
->left
);
5293 clean_up_modules (gsym
->right
);
5295 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
5298 gfc_current_ns
= gsym
->ns
;
5299 gfc_derived_types
= gfc_current_ns
->derived_types
;
5306 /* Translate all the program units. This could be in a different order
5307 to resolution if there are forward references in the file. */
5309 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
5313 gfc_current_ns
= gfc_global_ns_list
;
5314 gfc_get_errors (NULL
, &errors
);
5316 /* We first translate all modules to make sure that later parts
5317 of the program can use the decl. Then we translate the nonmodules. */
5319 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5321 if (!gfc_current_ns
->proc_name
5322 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5325 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5326 gfc_derived_types
= gfc_current_ns
->derived_types
;
5327 gfc_generate_module_code (gfc_current_ns
);
5328 gfc_current_ns
->translated
= 1;
5331 gfc_current_ns
= gfc_global_ns_list
;
5332 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5334 if (gfc_current_ns
->proc_name
5335 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5338 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5339 gfc_derived_types
= gfc_current_ns
->derived_types
;
5340 gfc_generate_code (gfc_current_ns
);
5341 gfc_current_ns
->translated
= 1;
5344 /* Clean up all the namespaces after translation. */
5345 gfc_current_ns
= gfc_global_ns_list
;
5346 for (;gfc_current_ns
;)
5350 if (gfc_current_ns
->proc_name
5351 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5353 gfc_current_ns
= gfc_current_ns
->sibling
;
5357 ns
= gfc_current_ns
->sibling
;
5358 gfc_derived_types
= gfc_current_ns
->derived_types
;
5360 gfc_current_ns
= ns
;
5363 clean_up_modules (gfc_gsym_root
);
5367 /* Top level parser. */
5370 gfc_parse_file (void)
5372 int seen_program
, errors_before
, errors
;
5373 gfc_state_data top
, s
;
5376 gfc_namespace
*next
;
5378 gfc_start_source_files ();
5380 top
.state
= COMP_NONE
;
5382 top
.previous
= NULL
;
5383 top
.head
= top
.tail
= NULL
;
5384 top
.do_variable
= NULL
;
5386 gfc_state_stack
= &top
;
5388 gfc_clear_new_st ();
5390 gfc_statement_label
= NULL
;
5392 if (setjmp (eof_buf
))
5393 return false; /* Come here on unexpected EOF */
5395 /* Prepare the global namespace that will contain the
5397 gfc_global_ns_list
= next
= NULL
;
5402 /* Exit early for empty files. */
5408 st
= next_statement ();
5417 goto duplicate_main
;
5419 prog_locus
= gfc_current_locus
;
5421 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
5422 main_program_symbol(gfc_current_ns
, gfc_new_block
->name
);
5423 accept_statement (st
);
5424 add_global_program ();
5425 parse_progunit (ST_NONE
);
5430 add_global_procedure (true);
5431 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
5432 accept_statement (st
);
5433 parse_progunit (ST_NONE
);
5438 add_global_procedure (false);
5439 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
5440 accept_statement (st
);
5441 parse_progunit (ST_NONE
);
5446 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
5447 accept_statement (st
);
5448 parse_block_data ();
5452 push_state (&s
, COMP_MODULE
, gfc_new_block
);
5453 accept_statement (st
);
5455 gfc_get_errors (NULL
, &errors_before
);
5459 /* Anything else starts a nameless main program block. */
5462 goto duplicate_main
;
5464 prog_locus
= gfc_current_locus
;
5466 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
5467 main_program_symbol (gfc_current_ns
, "MAIN__");
5468 parse_progunit (st
);
5473 /* Handle the non-program units. */
5474 gfc_current_ns
->code
= s
.head
;
5476 gfc_resolve (gfc_current_ns
);
5478 /* Dump the parse tree if requested. */
5479 if (flag_dump_fortran_original
)
5480 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
5482 gfc_get_errors (NULL
, &errors
);
5483 if (s
.state
== COMP_MODULE
)
5485 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
5486 gfc_current_ns
->derived_types
= gfc_derived_types
;
5487 gfc_derived_types
= NULL
;
5493 gfc_generate_code (gfc_current_ns
);
5501 /* The main program and non-contained procedures are put
5502 in the global namespace list, so that they can be processed
5503 later and all their interfaces resolved. */
5504 gfc_current_ns
->code
= s
.head
;
5507 for (; next
->sibling
; next
= next
->sibling
)
5509 next
->sibling
= gfc_current_ns
;
5512 gfc_global_ns_list
= gfc_current_ns
;
5514 next
= gfc_current_ns
;
5521 /* Do the resolution. */
5522 resolve_all_program_units (gfc_global_ns_list
);
5524 /* Do the parse tree dump. */
5526 = flag_dump_fortran_original
? gfc_global_ns_list
: NULL
;
5528 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5529 if (!gfc_current_ns
->proc_name
5530 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5532 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
5533 fputs ("------------------------------------------\n\n", stdout
);
5536 /* Do the translation. */
5537 translate_all_program_units (gfc_global_ns_list
);
5539 gfc_end_source_files ();
5543 /* If we see a duplicate main program, shut down. If the second
5544 instance is an implied main program, i.e. data decls or executable
5545 statements, we're in for lots of errors. */
5546 gfc_error_1 ("Two main PROGRAMs at %L and %C", &prog_locus
);
5547 reject_statement ();
5552 /* Return true if this state data represents an OpenACC region. */
5554 is_oacc (gfc_state_data
*sd
)
5556 switch (sd
->construct
->op
)
5558 case EXEC_OACC_PARALLEL_LOOP
:
5559 case EXEC_OACC_PARALLEL
:
5560 case EXEC_OACC_KERNELS_LOOP
:
5561 case EXEC_OACC_KERNELS
:
5562 case EXEC_OACC_DATA
:
5563 case EXEC_OACC_HOST_DATA
:
5564 case EXEC_OACC_LOOP
:
5565 case EXEC_OACC_UPDATE
:
5566 case EXEC_OACC_WAIT
:
5567 case EXEC_OACC_CACHE
:
5568 case EXEC_OACC_ENTER_DATA
:
5569 case EXEC_OACC_EXIT_DATA
: