2 Copyright (C) 2000-2016 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
23 #include "coretypes.h"
30 /* Current statement label. Zero means no statement label. Because new_st
31 can get wiped during statement matching, we have to keep it separate. */
33 gfc_st_label
*gfc_statement_label
;
35 static locus label_locus
;
36 static jmp_buf eof_buf
;
38 gfc_state_data
*gfc_state_stack
;
39 static bool last_was_use_stmt
= false;
41 /* TODO: Re-order functions to kill these forward decls. */
42 static void check_statement_label (gfc_statement
);
43 static void undo_new_statement (void);
44 static void reject_statement (void);
47 /* A sort of half-matching function. We try to match the word on the
48 input with the passed string. If this succeeds, we call the
49 keyword-dependent matching function that will match the rest of the
50 statement. For single keywords, the matching subroutine is
54 match_word (const char *str
, match (*subr
) (void), locus
*old_locus
)
69 gfc_current_locus
= *old_locus
;
77 /* Like match_word, but if str is matched, set a flag that it
80 match_word_omp_simd (const char *str
, match (*subr
) (void), locus
*old_locus
,
97 gfc_current_locus
= *old_locus
;
105 /* Load symbols from all USE statements encountered in this scoping unit. */
110 gfc_error_buffer old_error
;
112 gfc_push_error (&old_error
);
113 gfc_buffer_error (false);
115 gfc_buffer_error (true);
116 gfc_pop_error (&old_error
);
117 gfc_commit_symbols ();
118 gfc_warning_check ();
119 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
120 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
121 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
122 last_was_use_stmt
= false;
126 /* Figure out what the next statement is, (mostly) regardless of
127 proper ordering. The do...while(0) is there to prevent if/else
130 #define match(keyword, subr, st) \
132 if (match_word (keyword, subr, &old_locus) == MATCH_YES) \
135 undo_new_statement (); \
139 /* This is a specialist version of decode_statement that is used
140 for the specification statements in a function, whose
141 characteristics are deferred into the specification statements.
142 eg.: INTEGER (king = mykind) foo ()
143 USE mymodule, ONLY mykind.....
144 The KIND parameter needs a return after USE or IMPORT, whereas
145 derived type declarations can occur anywhere, up the executable
146 block. ST_GET_FCN_CHARACTERISTICS is returned when we have run
147 out of the correct kind of specification statements. */
149 decode_specification_statement (void)
155 if (gfc_match_eos () == MATCH_YES
)
158 old_locus
= gfc_current_locus
;
160 if (match_word ("use", gfc_match_use
, &old_locus
) == MATCH_YES
)
162 last_was_use_stmt
= true;
167 undo_new_statement ();
168 if (last_was_use_stmt
)
172 match ("import", gfc_match_import
, ST_IMPORT
);
174 if (gfc_current_block ()->result
->ts
.type
!= BT_DERIVED
)
177 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
178 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
179 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
181 /* General statement matching: Instead of testing every possible
182 statement, we eliminate most possibilities by peeking at the
185 c
= gfc_peek_ascii_char ();
190 match ("abstract% interface", gfc_match_abstract_interface
,
192 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
193 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
197 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
201 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
202 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
206 match ("data", gfc_match_data
, ST_DATA
);
207 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
211 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
212 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
213 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
214 match ("external", gfc_match_external
, ST_ATTR_DECL
);
218 match ("format", gfc_match_format
, ST_FORMAT
);
225 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
226 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
227 match ("interface", gfc_match_interface
, ST_INTERFACE
);
228 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
229 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
236 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
240 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
244 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
245 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
246 if (gfc_match_private (&st
) == MATCH_YES
)
248 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
249 if (gfc_match_public (&st
) == MATCH_YES
)
251 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
258 match ("save", gfc_match_save
, ST_ATTR_DECL
);
259 match ("structure", gfc_match_structure_decl
, ST_STRUCTURE_DECL
);
263 match ("target", gfc_match_target
, ST_ATTR_DECL
);
264 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
271 match ("value", gfc_match_value
, ST_ATTR_DECL
);
272 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
279 /* This is not a specification statement. See if any of the matchers
280 has stored an error message of some sort. */
284 gfc_buffer_error (false);
285 gfc_current_locus
= old_locus
;
287 return ST_GET_FCN_CHARACTERISTICS
;
290 static bool in_specification_block
;
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
);
361 if (in_specification_block
)
363 m
= match_word (NULL
, gfc_match_st_function
, &old_locus
);
365 return ST_STATEMENT_FUNCTION
;
368 if (!(in_specification_block
&& m
== MATCH_ERROR
))
370 match (NULL
, gfc_match_ptr_fcn_assign
, ST_ASSIGNMENT
);
373 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
374 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
376 /* Try to match a subroutine statement, which has the same optional
377 prefixes that functions can have. */
379 if (gfc_match_subroutine () == MATCH_YES
)
380 return ST_SUBROUTINE
;
382 gfc_current_locus
= old_locus
;
384 if (gfc_match_submod_proc () == MATCH_YES
)
386 if (gfc_new_block
->attr
.subroutine
)
387 return ST_SUBROUTINE
;
388 else if (gfc_new_block
->attr
.function
)
392 gfc_current_locus
= old_locus
;
394 /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
395 statements, which might begin with a block label. The match functions for
396 these statements are unusual in that their keyword is not seen before
397 the matcher is called. */
399 if (gfc_match_if (&st
) == MATCH_YES
)
402 gfc_current_locus
= old_locus
;
404 if (gfc_match_where (&st
) == MATCH_YES
)
407 gfc_current_locus
= old_locus
;
409 if (gfc_match_forall (&st
) == MATCH_YES
)
412 gfc_current_locus
= old_locus
;
414 match (NULL
, gfc_match_do
, ST_DO
);
415 match (NULL
, gfc_match_block
, ST_BLOCK
);
416 match (NULL
, gfc_match_associate
, ST_ASSOCIATE
);
417 match (NULL
, gfc_match_critical
, ST_CRITICAL
);
418 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
420 gfc_current_ns
= gfc_build_block_ns (gfc_current_ns
);
421 match (NULL
, gfc_match_select_type
, ST_SELECT_TYPE
);
423 gfc_current_ns
= gfc_current_ns
->parent
;
424 gfc_free_namespace (ns
);
426 /* General statement matching: Instead of testing every possible
427 statement, we eliminate most possibilities by peeking at the
433 match ("abstract% interface", gfc_match_abstract_interface
,
435 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
436 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
437 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
438 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
442 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
443 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
444 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
448 match ("call", gfc_match_call
, ST_CALL
);
449 match ("close", gfc_match_close
, ST_CLOSE
);
450 match ("continue", gfc_match_continue
, ST_CONTINUE
);
451 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
452 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
453 match ("case", gfc_match_case
, ST_CASE
);
454 match ("common", gfc_match_common
, ST_COMMON
);
455 match ("contains", gfc_match_eos
, ST_CONTAINS
);
456 match ("class", gfc_match_class_is
, ST_CLASS_IS
);
457 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
461 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
462 match ("data", gfc_match_data
, ST_DATA
);
463 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
467 match ("end file", gfc_match_endfile
, ST_END_FILE
);
468 match ("exit", gfc_match_exit
, ST_EXIT
);
469 match ("else", gfc_match_else
, ST_ELSE
);
470 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
471 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
472 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
);
473 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
475 if (gfc_match_end (&st
) == MATCH_YES
)
478 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
479 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
480 match ("external", gfc_match_external
, ST_ATTR_DECL
);
481 match ("event post", gfc_match_event_post
, ST_EVENT_POST
);
482 match ("event wait", gfc_match_event_wait
, ST_EVENT_WAIT
);
486 match ("final", gfc_match_final_decl
, ST_FINAL
);
487 match ("flush", gfc_match_flush
, ST_FLUSH
);
488 match ("format", gfc_match_format
, ST_FORMAT
);
492 match ("generic", gfc_match_generic
, ST_GENERIC
);
493 match ("go to", gfc_match_goto
, ST_GOTO
);
497 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
498 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
499 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
500 match ("import", gfc_match_import
, ST_IMPORT
);
501 match ("interface", gfc_match_interface
, ST_INTERFACE
);
502 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
503 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
507 match ("lock", gfc_match_lock
, ST_LOCK
);
511 match ("map", gfc_match_map
, ST_MAP
);
512 match ("module% procedure", gfc_match_modproc
, ST_MODULE_PROC
);
513 match ("module", gfc_match_module
, ST_MODULE
);
517 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
518 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
522 match ("open", gfc_match_open
, ST_OPEN
);
523 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
527 match ("print", gfc_match_print
, ST_WRITE
);
528 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
529 match ("pause", gfc_match_pause
, ST_PAUSE
);
530 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
531 if (gfc_match_private (&st
) == MATCH_YES
)
533 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
534 match ("program", gfc_match_program
, ST_PROGRAM
);
535 if (gfc_match_public (&st
) == MATCH_YES
)
537 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
541 match ("read", gfc_match_read
, ST_READ
);
542 match ("return", gfc_match_return
, ST_RETURN
);
543 match ("rewind", gfc_match_rewind
, ST_REWIND
);
547 match ("structure", gfc_match_structure_decl
, ST_STRUCTURE_DECL
);
548 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
549 match ("stop", gfc_match_stop
, ST_STOP
);
550 match ("save", gfc_match_save
, ST_ATTR_DECL
);
551 match ("submodule", gfc_match_submodule
, ST_SUBMODULE
);
552 match ("sync all", gfc_match_sync_all
, ST_SYNC_ALL
);
553 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
554 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
558 match ("target", gfc_match_target
, ST_ATTR_DECL
);
559 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
560 match ("type is", gfc_match_type_is
, ST_TYPE_IS
);
564 match ("union", gfc_match_union
, ST_UNION
);
565 match ("unlock", gfc_match_unlock
, ST_UNLOCK
);
569 match ("value", gfc_match_value
, ST_ATTR_DECL
);
570 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
574 match ("wait", gfc_match_wait
, ST_WAIT
);
575 match ("write", gfc_match_write
, ST_WRITE
);
579 /* All else has failed, so give up. See if any of the matchers has
580 stored an error message of some sort. */
582 if (!gfc_error_check ())
583 gfc_error_now ("Unclassifiable statement at %C");
587 gfc_error_recovery ();
592 /* Like match and if spec_only, goto do_spec_only without actually
594 #define matcha(keyword, subr, st) \
596 if (spec_only && gfc_match (keyword) == MATCH_YES) \
598 else if (match_word (keyword, subr, &old_locus) \
602 undo_new_statement (); \
606 decode_oacc_directive (void)
610 bool spec_only
= false;
612 gfc_enforce_clean_symbol_state ();
614 gfc_clear_error (); /* Clear any pending errors. */
615 gfc_clear_warning (); /* Clear any pending warnings. */
619 gfc_error_now ("OpenACC directives at %C may not appear in PURE "
621 gfc_error_recovery ();
625 if (gfc_current_state () == COMP_FUNCTION
626 && gfc_current_block ()->result
->ts
.kind
== -1)
629 gfc_unset_implicit_pure (NULL
);
631 old_locus
= gfc_current_locus
;
633 /* General OpenACC directive matching: Instead of testing every possible
634 statement, we eliminate most possibilities by peeking at the
637 c
= gfc_peek_ascii_char ();
642 matcha ("atomic", gfc_match_oacc_atomic
, ST_OACC_ATOMIC
);
645 matcha ("cache", gfc_match_oacc_cache
, ST_OACC_CACHE
);
648 matcha ("data", gfc_match_oacc_data
, ST_OACC_DATA
);
649 match ("declare", gfc_match_oacc_declare
, ST_OACC_DECLARE
);
652 matcha ("end atomic", gfc_match_omp_eos
, ST_OACC_END_ATOMIC
);
653 matcha ("end data", gfc_match_omp_eos
, ST_OACC_END_DATA
);
654 matcha ("end host_data", gfc_match_omp_eos
, ST_OACC_END_HOST_DATA
);
655 matcha ("end kernels loop", gfc_match_omp_eos
, ST_OACC_END_KERNELS_LOOP
);
656 matcha ("end kernels", gfc_match_omp_eos
, ST_OACC_END_KERNELS
);
657 matcha ("end loop", gfc_match_omp_eos
, ST_OACC_END_LOOP
);
658 matcha ("end parallel loop", gfc_match_omp_eos
,
659 ST_OACC_END_PARALLEL_LOOP
);
660 matcha ("end parallel", gfc_match_omp_eos
, ST_OACC_END_PARALLEL
);
661 matcha ("enter data", gfc_match_oacc_enter_data
, ST_OACC_ENTER_DATA
);
662 matcha ("exit data", gfc_match_oacc_exit_data
, ST_OACC_EXIT_DATA
);
665 matcha ("host_data", gfc_match_oacc_host_data
, ST_OACC_HOST_DATA
);
668 matcha ("parallel loop", gfc_match_oacc_parallel_loop
,
669 ST_OACC_PARALLEL_LOOP
);
670 matcha ("parallel", gfc_match_oacc_parallel
, ST_OACC_PARALLEL
);
673 matcha ("kernels loop", gfc_match_oacc_kernels_loop
,
674 ST_OACC_KERNELS_LOOP
);
675 matcha ("kernels", gfc_match_oacc_kernels
, ST_OACC_KERNELS
);
678 matcha ("loop", gfc_match_oacc_loop
, ST_OACC_LOOP
);
681 match ("routine", gfc_match_oacc_routine
, ST_OACC_ROUTINE
);
684 matcha ("update", gfc_match_oacc_update
, ST_OACC_UPDATE
);
687 matcha ("wait", gfc_match_oacc_wait
, ST_OACC_WAIT
);
691 /* Directive not found or stored an error message.
692 Check and give up. */
694 if (gfc_error_check () == 0)
695 gfc_error_now ("Unclassifiable OpenACC directive at %C");
699 gfc_error_recovery ();
706 gfc_buffer_error (false);
707 gfc_current_locus
= old_locus
;
708 return ST_GET_FCN_CHARACTERISTICS
;
711 /* Like match, but set a flag simd_matched if keyword matched
712 and if spec_only, goto do_spec_only without actually matching. */
713 #define matchs(keyword, subr, st) \
715 if (spec_only && gfc_match (keyword) == MATCH_YES) \
717 if (match_word_omp_simd (keyword, subr, &old_locus, \
718 &simd_matched) == MATCH_YES) \
721 undo_new_statement (); \
724 /* Like match, but don't match anything if not -fopenmp
725 and if spec_only, goto do_spec_only without actually matching. */
726 #define matcho(keyword, subr, st) \
730 else if (spec_only && gfc_match (keyword) == MATCH_YES) \
732 else if (match_word (keyword, subr, &old_locus) \
736 undo_new_statement (); \
739 /* Like match, but set a flag simd_matched if keyword matched. */
740 #define matchds(keyword, subr, st) \
742 if (match_word_omp_simd (keyword, subr, &old_locus, \
743 &simd_matched) == MATCH_YES) \
746 undo_new_statement (); \
749 /* Like match, but don't match anything if not -fopenmp. */
750 #define matchdo(keyword, subr, st) \
754 else if (match_word (keyword, subr, &old_locus) \
758 undo_new_statement (); \
762 decode_omp_directive (void)
766 bool simd_matched
= false;
767 bool spec_only
= false;
769 gfc_enforce_clean_symbol_state ();
771 gfc_clear_error (); /* Clear any pending errors. */
772 gfc_clear_warning (); /* Clear any pending warnings. */
776 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
777 "or ELEMENTAL procedures");
778 gfc_error_recovery ();
782 if (gfc_current_state () == COMP_FUNCTION
783 && gfc_current_block ()->result
->ts
.kind
== -1)
786 gfc_unset_implicit_pure (NULL
);
788 old_locus
= gfc_current_locus
;
790 /* General OpenMP directive matching: Instead of testing every possible
791 statement, we eliminate most possibilities by peeking at the
794 c
= gfc_peek_ascii_char ();
796 /* match is for directives that should be recognized only if
797 -fopenmp, matchs for directives that should be recognized
798 if either -fopenmp or -fopenmp-simd. */
802 matcho ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
805 matcho ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
808 matcho ("cancellation% point", gfc_match_omp_cancellation_point
,
809 ST_OMP_CANCELLATION_POINT
);
810 matcho ("cancel", gfc_match_omp_cancel
, ST_OMP_CANCEL
);
811 matcho ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
814 matchds ("declare reduction", gfc_match_omp_declare_reduction
,
815 ST_OMP_DECLARE_REDUCTION
);
816 matchds ("declare simd", gfc_match_omp_declare_simd
,
817 ST_OMP_DECLARE_SIMD
);
818 matchdo ("declare target", gfc_match_omp_declare_target
,
819 ST_OMP_DECLARE_TARGET
);
820 matchs ("distribute parallel do simd",
821 gfc_match_omp_distribute_parallel_do_simd
,
822 ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
);
823 matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do
,
824 ST_OMP_DISTRIBUTE_PARALLEL_DO
);
825 matchs ("distribute simd", gfc_match_omp_distribute_simd
,
826 ST_OMP_DISTRIBUTE_SIMD
);
827 matcho ("distribute", gfc_match_omp_distribute
, ST_OMP_DISTRIBUTE
);
828 matchs ("do simd", gfc_match_omp_do_simd
, ST_OMP_DO_SIMD
);
829 matcho ("do", gfc_match_omp_do
, ST_OMP_DO
);
832 matcho ("end atomic", gfc_match_omp_eos
, ST_OMP_END_ATOMIC
);
833 matcho ("end critical", gfc_match_omp_critical
, ST_OMP_END_CRITICAL
);
834 matchs ("end distribute parallel do simd", gfc_match_omp_eos
,
835 ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
);
836 matcho ("end distribute parallel do", gfc_match_omp_eos
,
837 ST_OMP_END_DISTRIBUTE_PARALLEL_DO
);
838 matchs ("end distribute simd", gfc_match_omp_eos
,
839 ST_OMP_END_DISTRIBUTE_SIMD
);
840 matcho ("end distribute", gfc_match_omp_eos
, ST_OMP_END_DISTRIBUTE
);
841 matchs ("end do simd", gfc_match_omp_end_nowait
, ST_OMP_END_DO_SIMD
);
842 matcho ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
843 matchs ("end simd", gfc_match_omp_eos
, ST_OMP_END_SIMD
);
844 matcho ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
845 matcho ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
846 matchs ("end parallel do simd", gfc_match_omp_eos
,
847 ST_OMP_END_PARALLEL_DO_SIMD
);
848 matcho ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
849 matcho ("end parallel sections", gfc_match_omp_eos
,
850 ST_OMP_END_PARALLEL_SECTIONS
);
851 matcho ("end parallel workshare", gfc_match_omp_eos
,
852 ST_OMP_END_PARALLEL_WORKSHARE
);
853 matcho ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
854 matcho ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
855 matcho ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
856 matcho ("end target data", gfc_match_omp_eos
, ST_OMP_END_TARGET_DATA
);
857 matchs ("end target teams distribute parallel do simd",
859 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
860 matcho ("end target teams distribute parallel do", gfc_match_omp_eos
,
861 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
862 matchs ("end target teams distribute simd", gfc_match_omp_eos
,
863 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
);
864 matcho ("end target teams distribute", gfc_match_omp_eos
,
865 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
);
866 matcho ("end target teams", gfc_match_omp_eos
, ST_OMP_END_TARGET_TEAMS
);
867 matcho ("end target", gfc_match_omp_eos
, ST_OMP_END_TARGET
);
868 matcho ("end taskgroup", gfc_match_omp_eos
, ST_OMP_END_TASKGROUP
);
869 matcho ("end task", gfc_match_omp_eos
, ST_OMP_END_TASK
);
870 matchs ("end teams distribute parallel do simd", gfc_match_omp_eos
,
871 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
872 matcho ("end teams distribute parallel do", gfc_match_omp_eos
,
873 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
);
874 matchs ("end teams distribute simd", gfc_match_omp_eos
,
875 ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
);
876 matcho ("end teams distribute", gfc_match_omp_eos
,
877 ST_OMP_END_TEAMS_DISTRIBUTE
);
878 matcho ("end teams", gfc_match_omp_eos
, ST_OMP_END_TEAMS
);
879 matcho ("end workshare", gfc_match_omp_end_nowait
,
880 ST_OMP_END_WORKSHARE
);
883 matcho ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
886 matcho ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
889 matcho ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
892 matchs ("parallel do simd", gfc_match_omp_parallel_do_simd
,
893 ST_OMP_PARALLEL_DO_SIMD
);
894 matcho ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
895 matcho ("parallel sections", gfc_match_omp_parallel_sections
,
896 ST_OMP_PARALLEL_SECTIONS
);
897 matcho ("parallel workshare", gfc_match_omp_parallel_workshare
,
898 ST_OMP_PARALLEL_WORKSHARE
);
899 matcho ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
902 matcho ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
903 matcho ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
904 matchs ("simd", gfc_match_omp_simd
, ST_OMP_SIMD
);
905 matcho ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
908 matcho ("target data", gfc_match_omp_target_data
, ST_OMP_TARGET_DATA
);
909 matchs ("target teams distribute parallel do simd",
910 gfc_match_omp_target_teams_distribute_parallel_do_simd
,
911 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
912 matcho ("target teams distribute parallel do",
913 gfc_match_omp_target_teams_distribute_parallel_do
,
914 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
915 matchs ("target teams distribute simd",
916 gfc_match_omp_target_teams_distribute_simd
,
917 ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
);
918 matcho ("target teams distribute", gfc_match_omp_target_teams_distribute
,
919 ST_OMP_TARGET_TEAMS_DISTRIBUTE
);
920 matcho ("target teams", gfc_match_omp_target_teams
, ST_OMP_TARGET_TEAMS
);
921 matcho ("target update", gfc_match_omp_target_update
,
922 ST_OMP_TARGET_UPDATE
);
923 matcho ("target", gfc_match_omp_target
, ST_OMP_TARGET
);
924 matcho ("taskgroup", gfc_match_omp_taskgroup
, ST_OMP_TASKGROUP
);
925 matcho ("taskwait", gfc_match_omp_taskwait
, ST_OMP_TASKWAIT
);
926 matcho ("taskyield", gfc_match_omp_taskyield
, ST_OMP_TASKYIELD
);
927 matcho ("task", gfc_match_omp_task
, ST_OMP_TASK
);
928 matchs ("teams distribute parallel do simd",
929 gfc_match_omp_teams_distribute_parallel_do_simd
,
930 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
931 matcho ("teams distribute parallel do",
932 gfc_match_omp_teams_distribute_parallel_do
,
933 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
);
934 matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd
,
935 ST_OMP_TEAMS_DISTRIBUTE_SIMD
);
936 matcho ("teams distribute", gfc_match_omp_teams_distribute
,
937 ST_OMP_TEAMS_DISTRIBUTE
);
938 matcho ("teams", gfc_match_omp_teams
, ST_OMP_TEAMS
);
939 matchdo ("threadprivate", gfc_match_omp_threadprivate
,
940 ST_OMP_THREADPRIVATE
);
943 matcho ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
947 /* All else has failed, so give up. See if any of the matchers has
948 stored an error message of some sort. Don't error out if
949 not -fopenmp and simd_matched is false, i.e. if a directive other
950 than one marked with match has been seen. */
952 if (flag_openmp
|| simd_matched
)
954 if (!gfc_error_check ())
955 gfc_error_now ("Unclassifiable OpenMP directive at %C");
960 gfc_error_recovery ();
967 gfc_buffer_error (false);
968 gfc_current_locus
= old_locus
;
969 return ST_GET_FCN_CHARACTERISTICS
;
973 decode_gcc_attribute (void)
977 gfc_enforce_clean_symbol_state ();
979 gfc_clear_error (); /* Clear any pending errors. */
980 gfc_clear_warning (); /* Clear any pending warnings. */
981 old_locus
= gfc_current_locus
;
983 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
985 /* All else has failed, so give up. See if any of the matchers has
986 stored an error message of some sort. */
988 if (!gfc_error_check ())
989 gfc_error_now ("Unclassifiable GCC directive at %C");
993 gfc_error_recovery ();
1000 /* Assert next length characters to be equal to token in free form. */
1003 verify_token_free (const char* token
, int length
, bool last_was_use_stmt
)
1008 c
= gfc_next_ascii_char ();
1009 for (i
= 0; i
< length
; i
++, c
= gfc_next_ascii_char ())
1010 gcc_assert (c
== token
[i
]);
1012 gcc_assert (gfc_is_whitespace(c
));
1013 gfc_gobble_whitespace ();
1014 if (last_was_use_stmt
)
1018 /* Get the next statement in free form source. */
1020 static gfc_statement
1027 at_bol
= gfc_at_bol ();
1028 gfc_gobble_whitespace ();
1030 c
= gfc_peek_ascii_char ();
1036 /* Found a statement label? */
1037 m
= gfc_match_st_label (&gfc_statement_label
);
1039 d
= gfc_peek_ascii_char ();
1040 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
1042 gfc_match_small_literal_int (&i
, &cnt
);
1045 gfc_error_now ("Too many digits in statement label at %C");
1048 gfc_error_now ("Zero is not a valid statement label at %C");
1051 c
= gfc_next_ascii_char ();
1054 if (!gfc_is_whitespace (c
))
1055 gfc_error_now ("Non-numeric character in statement label at %C");
1061 label_locus
= gfc_current_locus
;
1063 gfc_gobble_whitespace ();
1065 if (at_bol
&& gfc_peek_ascii_char () == ';')
1067 gfc_error_now ("Semicolon at %C needs to be preceded by "
1069 gfc_next_ascii_char (); /* Eat up the semicolon. */
1073 if (gfc_match_eos () == MATCH_YES
)
1074 gfc_error_now ("Statement label without statement at %L",
1080 /* Comments have already been skipped by the time we get here,
1081 except for GCC attributes and OpenMP/OpenACC directives. */
1083 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
1084 c
= gfc_peek_ascii_char ();
1090 c
= gfc_next_ascii_char ();
1091 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
1092 gcc_assert (c
== "gcc$"[i
]);
1094 gfc_gobble_whitespace ();
1095 return decode_gcc_attribute ();
1100 /* Since both OpenMP and OpenACC directives starts with
1101 !$ character sequence, we must check all flags combinations */
1102 if ((flag_openmp
|| flag_openmp_simd
)
1105 verify_token_free ("$omp", 4, last_was_use_stmt
);
1106 return decode_omp_directive ();
1108 else if ((flag_openmp
|| flag_openmp_simd
)
1111 gfc_next_ascii_char (); /* Eat up dollar character */
1112 c
= gfc_peek_ascii_char ();
1116 verify_token_free ("omp", 3, last_was_use_stmt
);
1117 return decode_omp_directive ();
1121 verify_token_free ("acc", 3, last_was_use_stmt
);
1122 return decode_oacc_directive ();
1125 else if (flag_openacc
)
1127 verify_token_free ("$acc", 4, last_was_use_stmt
);
1128 return decode_oacc_directive ();
1134 if (at_bol
&& c
== ';')
1136 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1137 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1139 gfc_next_ascii_char (); /* Eat up the semicolon. */
1143 return decode_statement ();
1146 /* Assert next length characters to be equal to token in fixed form. */
1149 verify_token_fixed (const char *token
, int length
, bool last_was_use_stmt
)
1152 char c
= gfc_next_char_literal (NONSTRING
);
1154 for (i
= 0; i
< length
; i
++, c
= gfc_next_char_literal (NONSTRING
))
1155 gcc_assert ((char) gfc_wide_tolower (c
) == token
[i
]);
1157 if (c
!= ' ' && c
!= '0')
1159 gfc_buffer_error (false);
1160 gfc_error ("Bad continuation line at %C");
1163 if (last_was_use_stmt
)
1169 /* Get the next statement in fixed-form source. */
1171 static gfc_statement
1174 int label
, digit_flag
, i
;
1179 return decode_statement ();
1181 /* Skip past the current label field, parsing a statement label if
1182 one is there. This is a weird number parser, since the number is
1183 contained within five columns and can have any kind of embedded
1184 spaces. We also check for characters that make the rest of the
1190 for (i
= 0; i
< 5; i
++)
1192 c
= gfc_next_char_literal (NONSTRING
);
1209 label
= label
* 10 + ((unsigned char) c
- '0');
1210 label_locus
= gfc_current_locus
;
1214 /* Comments have already been skipped by the time we get
1215 here, except for GCC attributes and OpenMP directives. */
1218 c
= gfc_next_char_literal (NONSTRING
);
1220 if (TOLOWER (c
) == 'g')
1222 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
1223 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
1225 return decode_gcc_attribute ();
1229 if ((flag_openmp
|| flag_openmp_simd
)
1232 if (!verify_token_fixed ("omp", 3, last_was_use_stmt
))
1234 return decode_omp_directive ();
1236 else if ((flag_openmp
|| flag_openmp_simd
)
1239 c
= gfc_next_char_literal(NONSTRING
);
1240 if (c
== 'o' || c
== 'O')
1242 if (!verify_token_fixed ("mp", 2, last_was_use_stmt
))
1244 return decode_omp_directive ();
1246 else if (c
== 'a' || c
== 'A')
1248 if (!verify_token_fixed ("cc", 2, last_was_use_stmt
))
1250 return decode_oacc_directive ();
1253 else if (flag_openacc
)
1255 if (!verify_token_fixed ("acc", 3, last_was_use_stmt
))
1257 return decode_oacc_directive ();
1262 /* Comments have already been skipped by the time we get
1263 here so don't bother checking for them. */
1266 gfc_buffer_error (false);
1267 gfc_error ("Non-numeric character in statement label at %C");
1275 gfc_warning_now (0, "Zero is not a valid statement label at %C");
1278 /* We've found a valid statement label. */
1279 gfc_statement_label
= gfc_get_st_label (label
);
1283 /* Since this line starts a statement, it cannot be a continuation
1284 of a previous statement. If we see something here besides a
1285 space or zero, it must be a bad continuation line. */
1287 c
= gfc_next_char_literal (NONSTRING
);
1291 if (c
!= ' ' && c
!= '0')
1293 gfc_buffer_error (false);
1294 gfc_error ("Bad continuation line at %C");
1298 /* Now that we've taken care of the statement label columns, we have
1299 to make sure that the first nonblank character is not a '!'. If
1300 it is, the rest of the line is a comment. */
1304 loc
= gfc_current_locus
;
1305 c
= gfc_next_char_literal (NONSTRING
);
1307 while (gfc_is_whitespace (c
));
1311 gfc_current_locus
= loc
;
1316 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1317 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1318 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1323 if (gfc_match_eos () == MATCH_YES
)
1326 /* At this point, we've got a nonblank statement to parse. */
1327 return decode_statement ();
1331 gfc_error_now ("Statement label without statement at %L", &label_locus
);
1333 gfc_current_locus
.lb
->truncated
= 0;
1334 gfc_advance_line ();
1339 /* Return the next non-ST_NONE statement to the caller. We also worry
1340 about including files and the ends of include files at this stage. */
1342 static gfc_statement
1343 next_statement (void)
1348 gfc_enforce_clean_symbol_state ();
1350 gfc_new_block
= NULL
;
1352 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
1353 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1354 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
1357 gfc_statement_label
= NULL
;
1358 gfc_buffer_error (true);
1361 gfc_advance_line ();
1363 gfc_skip_comments ();
1371 if (gfc_define_undef_line ())
1374 old_locus
= gfc_current_locus
;
1376 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1382 gfc_buffer_error (false);
1384 if (st
== ST_GET_FCN_CHARACTERISTICS
)
1386 if (gfc_statement_label
!= NULL
)
1388 gfc_free_st_label (gfc_statement_label
);
1389 gfc_statement_label
= NULL
;
1391 gfc_current_locus
= old_locus
;
1395 check_statement_label (st
);
1401 /****************************** Parser ***********************************/
1403 /* The parser subroutines are of type 'try' that fail if the file ends
1406 /* Macros that expand to case-labels for various classes of
1407 statements. Start with executable statements that directly do
1410 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1411 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1412 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1413 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1414 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1415 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1416 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1417 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1418 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1419 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
1420 case ST_OMP_TARGET_UPDATE: case ST_ERROR_STOP: case ST_SYNC_ALL: \
1421 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1422 case ST_EVENT_POST: case ST_EVENT_WAIT: \
1423 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1424 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1426 /* Statements that mark other executable statements. */
1428 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1429 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1430 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1431 case ST_OMP_PARALLEL: \
1432 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1433 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
1434 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1435 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1436 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1437 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1438 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1439 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1440 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1441 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1442 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1443 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1444 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1445 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1446 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1447 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1448 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: \
1450 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1451 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
1452 case ST_OACC_KERNELS_LOOP: case ST_OACC_ATOMIC
1454 /* Declaration statements */
1456 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1457 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1458 case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE: case ST_OACC_ROUTINE: \
1459 case ST_OACC_DECLARE
1461 /* OpenMP declaration statements. */
1463 #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
1464 case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION
1466 /* Block end statements. Errors associated with interchanging these
1467 are detected in gfc_match_end(). */
1469 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1470 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1471 case ST_END_BLOCK: case ST_END_ASSOCIATE
1474 /* Push a new state onto the stack. */
1477 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1479 p
->state
= new_state
;
1480 p
->previous
= gfc_state_stack
;
1482 p
->head
= p
->tail
= NULL
;
1483 p
->do_variable
= NULL
;
1484 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1485 p
->ext
.oacc_declare_clauses
= NULL
;
1487 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1488 construct statement was accepted right before pushing the state. Thus,
1489 the construct's gfc_code is available as tail of the parent state. */
1490 gcc_assert (gfc_state_stack
);
1491 p
->construct
= gfc_state_stack
->tail
;
1493 gfc_state_stack
= p
;
1497 /* Pop the current state. */
1501 gfc_state_stack
= gfc_state_stack
->previous
;
1505 /* Try to find the given state in the state stack. */
1508 gfc_find_state (gfc_compile_state state
)
1512 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1513 if (p
->state
== state
)
1516 return (p
== NULL
) ? false : true;
1520 /* Starts a new level in the statement list. */
1523 new_level (gfc_code
*q
)
1527 p
= q
->block
= gfc_get_code (EXEC_NOP
);
1529 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1535 /* Add the current new_st code structure and adds it to the current
1536 program unit. As a side-effect, it zeroes the new_st. */
1539 add_statement (void)
1543 p
= XCNEW (gfc_code
);
1546 p
->loc
= gfc_current_locus
;
1548 if (gfc_state_stack
->head
== NULL
)
1549 gfc_state_stack
->head
= p
;
1551 gfc_state_stack
->tail
->next
= p
;
1553 while (p
->next
!= NULL
)
1556 gfc_state_stack
->tail
= p
;
1558 gfc_clear_new_st ();
1564 /* Frees everything associated with the current statement. */
1567 undo_new_statement (void)
1569 gfc_free_statements (new_st
.block
);
1570 gfc_free_statements (new_st
.next
);
1571 gfc_free_statement (&new_st
);
1572 gfc_clear_new_st ();
1576 /* If the current statement has a statement label, make sure that it
1577 is allowed to, or should have one. */
1580 check_statement_label (gfc_statement st
)
1584 if (gfc_statement_label
== NULL
)
1586 if (st
== ST_FORMAT
)
1587 gfc_error ("FORMAT statement at %L does not have a statement label",
1594 case ST_END_PROGRAM
:
1595 case ST_END_FUNCTION
:
1596 case ST_END_SUBROUTINE
:
1600 case ST_END_CRITICAL
:
1602 case ST_END_ASSOCIATE
:
1605 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
1606 type
= ST_LABEL_DO_TARGET
;
1608 type
= ST_LABEL_TARGET
;
1612 type
= ST_LABEL_FORMAT
;
1615 /* Statement labels are not restricted from appearing on a
1616 particular line. However, there are plenty of situations
1617 where the resulting label can't be referenced. */
1620 type
= ST_LABEL_BAD_TARGET
;
1624 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1626 new_st
.here
= gfc_statement_label
;
1630 /* Figures out what the enclosing program unit is. This will be a
1631 function, subroutine, program, block data or module. */
1634 gfc_enclosing_unit (gfc_compile_state
* result
)
1638 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1639 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1640 || p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
1641 || p
->state
== COMP_BLOCK_DATA
|| p
->state
== COMP_PROGRAM
)
1650 *result
= COMP_PROGRAM
;
1655 /* Translate a statement enum to a string. */
1658 gfc_ascii_statement (gfc_statement st
)
1664 case ST_ARITHMETIC_IF
:
1665 p
= _("arithmetic IF");
1674 p
= _("attribute declaration");
1710 p
= _("data declaration");
1724 case ST_STRUCTURE_DECL
:
1727 case ST_DERIVED_DECL
:
1728 p
= _("derived type declaration");
1748 case ST_END_ASSOCIATE
:
1749 p
= "END ASSOCIATE";
1754 case ST_END_BLOCK_DATA
:
1755 p
= "END BLOCK DATA";
1757 case ST_END_CRITICAL
:
1769 case ST_END_FUNCTION
:
1775 case ST_END_INTERFACE
:
1776 p
= "END INTERFACE";
1781 case ST_END_SUBMODULE
:
1782 p
= "END SUBMODULE";
1784 case ST_END_PROGRAM
:
1790 case ST_END_SUBROUTINE
:
1791 p
= "END SUBROUTINE";
1796 case ST_END_STRUCTURE
:
1797 p
= "END STRUCTURE";
1811 case ST_EQUIVALENCE
:
1823 case ST_FORALL_BLOCK
: /* Fall through */
1845 case ST_IMPLICIT_NONE
:
1846 p
= "IMPLICIT NONE";
1848 case ST_IMPLIED_ENDDO
:
1849 p
= _("implied END DO");
1881 case ST_MODULE_PROC
:
1882 p
= "MODULE PROCEDURE";
1914 case ST_SYNC_IMAGES
:
1917 case ST_SYNC_MEMORY
:
1932 case ST_WHERE_BLOCK
: /* Fall through */
1943 p
= _("assignment");
1945 case ST_POINTER_ASSIGNMENT
:
1946 p
= _("pointer assignment");
1948 case ST_SELECT_CASE
:
1951 case ST_SELECT_TYPE
:
1966 case ST_STATEMENT_FUNCTION
:
1967 p
= "STATEMENT FUNCTION";
1969 case ST_LABEL_ASSIGNMENT
:
1970 p
= "LABEL ASSIGNMENT";
1973 p
= "ENUM DEFINITION";
1976 p
= "ENUMERATOR DEFINITION";
1981 case ST_OACC_PARALLEL_LOOP
:
1982 p
= "!$ACC PARALLEL LOOP";
1984 case ST_OACC_END_PARALLEL_LOOP
:
1985 p
= "!$ACC END PARALLEL LOOP";
1987 case ST_OACC_PARALLEL
:
1988 p
= "!$ACC PARALLEL";
1990 case ST_OACC_END_PARALLEL
:
1991 p
= "!$ACC END PARALLEL";
1993 case ST_OACC_KERNELS
:
1994 p
= "!$ACC KERNELS";
1996 case ST_OACC_END_KERNELS
:
1997 p
= "!$ACC END KERNELS";
1999 case ST_OACC_KERNELS_LOOP
:
2000 p
= "!$ACC KERNELS LOOP";
2002 case ST_OACC_END_KERNELS_LOOP
:
2003 p
= "!$ACC END KERNELS LOOP";
2008 case ST_OACC_END_DATA
:
2009 p
= "!$ACC END DATA";
2011 case ST_OACC_HOST_DATA
:
2012 p
= "!$ACC HOST_DATA";
2014 case ST_OACC_END_HOST_DATA
:
2015 p
= "!$ACC END HOST_DATA";
2020 case ST_OACC_END_LOOP
:
2021 p
= "!$ACC END LOOP";
2023 case ST_OACC_DECLARE
:
2024 p
= "!$ACC DECLARE";
2026 case ST_OACC_UPDATE
:
2035 case ST_OACC_ENTER_DATA
:
2036 p
= "!$ACC ENTER DATA";
2038 case ST_OACC_EXIT_DATA
:
2039 p
= "!$ACC EXIT DATA";
2041 case ST_OACC_ROUTINE
:
2042 p
= "!$ACC ROUTINE";
2044 case ST_OACC_ATOMIC
:
2047 case ST_OACC_END_ATOMIC
:
2048 p
= "!ACC END ATOMIC";
2053 case ST_OMP_BARRIER
:
2054 p
= "!$OMP BARRIER";
2059 case ST_OMP_CANCELLATION_POINT
:
2060 p
= "!$OMP CANCELLATION POINT";
2062 case ST_OMP_CRITICAL
:
2063 p
= "!$OMP CRITICAL";
2065 case ST_OMP_DECLARE_REDUCTION
:
2066 p
= "!$OMP DECLARE REDUCTION";
2068 case ST_OMP_DECLARE_SIMD
:
2069 p
= "!$OMP DECLARE SIMD";
2071 case ST_OMP_DECLARE_TARGET
:
2072 p
= "!$OMP DECLARE TARGET";
2074 case ST_OMP_DISTRIBUTE
:
2075 p
= "!$OMP DISTRIBUTE";
2077 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
2078 p
= "!$OMP DISTRIBUTE PARALLEL DO";
2080 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2081 p
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
2083 case ST_OMP_DISTRIBUTE_SIMD
:
2084 p
= "!$OMP DISTRIBUTE SIMD";
2089 case ST_OMP_DO_SIMD
:
2090 p
= "!$OMP DO SIMD";
2092 case ST_OMP_END_ATOMIC
:
2093 p
= "!$OMP END ATOMIC";
2095 case ST_OMP_END_CRITICAL
:
2096 p
= "!$OMP END CRITICAL";
2098 case ST_OMP_END_DISTRIBUTE
:
2099 p
= "!$OMP END DISTRIBUTE";
2101 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO
:
2102 p
= "!$OMP END DISTRIBUTE PARALLEL DO";
2104 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
:
2105 p
= "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
2107 case ST_OMP_END_DISTRIBUTE_SIMD
:
2108 p
= "!$OMP END DISTRIBUTE SIMD";
2113 case ST_OMP_END_DO_SIMD
:
2114 p
= "!$OMP END DO SIMD";
2116 case ST_OMP_END_SIMD
:
2117 p
= "!$OMP END SIMD";
2119 case ST_OMP_END_MASTER
:
2120 p
= "!$OMP END MASTER";
2122 case ST_OMP_END_ORDERED
:
2123 p
= "!$OMP END ORDERED";
2125 case ST_OMP_END_PARALLEL
:
2126 p
= "!$OMP END PARALLEL";
2128 case ST_OMP_END_PARALLEL_DO
:
2129 p
= "!$OMP END PARALLEL DO";
2131 case ST_OMP_END_PARALLEL_DO_SIMD
:
2132 p
= "!$OMP END PARALLEL DO SIMD";
2134 case ST_OMP_END_PARALLEL_SECTIONS
:
2135 p
= "!$OMP END PARALLEL SECTIONS";
2137 case ST_OMP_END_PARALLEL_WORKSHARE
:
2138 p
= "!$OMP END PARALLEL WORKSHARE";
2140 case ST_OMP_END_SECTIONS
:
2141 p
= "!$OMP END SECTIONS";
2143 case ST_OMP_END_SINGLE
:
2144 p
= "!$OMP END SINGLE";
2146 case ST_OMP_END_TASK
:
2147 p
= "!$OMP END TASK";
2149 case ST_OMP_END_TARGET
:
2150 p
= "!$OMP END TARGET";
2152 case ST_OMP_END_TARGET_DATA
:
2153 p
= "!$OMP END TARGET DATA";
2155 case ST_OMP_END_TARGET_TEAMS
:
2156 p
= "!$OMP END TARGET TEAMS";
2158 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
:
2159 p
= "!$OMP END TARGET TEAMS DISTRIBUTE";
2161 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2162 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2164 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2165 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2167 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2168 p
= "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2170 case ST_OMP_END_TASKGROUP
:
2171 p
= "!$OMP END TASKGROUP";
2173 case ST_OMP_END_TEAMS
:
2174 p
= "!$OMP END TEAMS";
2176 case ST_OMP_END_TEAMS_DISTRIBUTE
:
2177 p
= "!$OMP END TEAMS DISTRIBUTE";
2179 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2180 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2182 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2183 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2185 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
:
2186 p
= "!$OMP END TEAMS DISTRIBUTE SIMD";
2188 case ST_OMP_END_WORKSHARE
:
2189 p
= "!$OMP END WORKSHARE";
2197 case ST_OMP_ORDERED
:
2198 p
= "!$OMP ORDERED";
2200 case ST_OMP_PARALLEL
:
2201 p
= "!$OMP PARALLEL";
2203 case ST_OMP_PARALLEL_DO
:
2204 p
= "!$OMP PARALLEL DO";
2206 case ST_OMP_PARALLEL_DO_SIMD
:
2207 p
= "!$OMP PARALLEL DO SIMD";
2209 case ST_OMP_PARALLEL_SECTIONS
:
2210 p
= "!$OMP PARALLEL SECTIONS";
2212 case ST_OMP_PARALLEL_WORKSHARE
:
2213 p
= "!$OMP PARALLEL WORKSHARE";
2215 case ST_OMP_SECTIONS
:
2216 p
= "!$OMP SECTIONS";
2218 case ST_OMP_SECTION
:
2219 p
= "!$OMP SECTION";
2230 case ST_OMP_TARGET_DATA
:
2231 p
= "!$OMP TARGET DATA";
2233 case ST_OMP_TARGET_TEAMS
:
2234 p
= "!$OMP TARGET TEAMS";
2236 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
2237 p
= "!$OMP TARGET TEAMS DISTRIBUTE";
2239 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2240 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2242 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2243 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2245 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2246 p
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2248 case ST_OMP_TARGET_UPDATE
:
2249 p
= "!$OMP TARGET UPDATE";
2254 case ST_OMP_TASKGROUP
:
2255 p
= "!$OMP TASKGROUP";
2257 case ST_OMP_TASKWAIT
:
2258 p
= "!$OMP TASKWAIT";
2260 case ST_OMP_TASKYIELD
:
2261 p
= "!$OMP TASKYIELD";
2266 case ST_OMP_TEAMS_DISTRIBUTE
:
2267 p
= "!$OMP TEAMS DISTRIBUTE";
2269 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2270 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2272 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2273 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2275 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
2276 p
= "!$OMP TEAMS DISTRIBUTE SIMD";
2278 case ST_OMP_THREADPRIVATE
:
2279 p
= "!$OMP THREADPRIVATE";
2281 case ST_OMP_WORKSHARE
:
2282 p
= "!$OMP WORKSHARE";
2285 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2292 /* Create a symbol for the main program and assign it to ns->proc_name. */
2295 main_program_symbol (gfc_namespace
*ns
, const char *name
)
2297 gfc_symbol
*main_program
;
2298 symbol_attribute attr
;
2300 gfc_get_symbol (name
, ns
, &main_program
);
2301 gfc_clear_attr (&attr
);
2302 attr
.flavor
= FL_PROGRAM
;
2303 attr
.proc
= PROC_UNKNOWN
;
2304 attr
.subroutine
= 1;
2305 attr
.access
= ACCESS_PUBLIC
;
2306 attr
.is_main_program
= 1;
2307 main_program
->attr
= attr
;
2308 main_program
->declared_at
= gfc_current_locus
;
2309 ns
->proc_name
= main_program
;
2310 gfc_commit_symbols ();
2314 /* Do whatever is necessary to accept the last statement. */
2317 accept_statement (gfc_statement st
)
2321 case ST_IMPLICIT_NONE
:
2329 gfc_current_ns
->proc_name
= gfc_new_block
;
2332 /* If the statement is the end of a block, lay down a special code
2333 that allows a branch to the end of the block from within the
2334 construct. IF and SELECT are treated differently from DO
2335 (where EXEC_NOP is added inside the loop) for two
2337 1. END DO has a meaning in the sense that after a GOTO to
2338 it, the loop counter must be increased.
2339 2. IF blocks and SELECT blocks can consist of multiple
2340 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
2341 Putting the label before the END IF would make the jump
2342 from, say, the ELSE IF block to the END IF illegal. */
2346 case ST_END_CRITICAL
:
2347 if (gfc_statement_label
!= NULL
)
2349 new_st
.op
= EXEC_END_NESTED_BLOCK
;
2354 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
2355 one parallel block. Thus, we add the special code to the nested block
2356 itself, instead of the parent one. */
2358 case ST_END_ASSOCIATE
:
2359 if (gfc_statement_label
!= NULL
)
2361 new_st
.op
= EXEC_END_BLOCK
;
2366 /* The end-of-program unit statements do not get the special
2367 marker and require a statement of some sort if they are a
2370 case ST_END_PROGRAM
:
2371 case ST_END_FUNCTION
:
2372 case ST_END_SUBROUTINE
:
2373 if (gfc_statement_label
!= NULL
)
2375 new_st
.op
= EXEC_RETURN
;
2380 new_st
.op
= EXEC_END_PROCEDURE
;
2396 gfc_commit_symbols ();
2397 gfc_warning_check ();
2398 gfc_clear_new_st ();
2402 /* Undo anything tentative that has been built for the current
2406 reject_statement (void)
2408 /* Revert to the previous charlen chain. */
2409 gfc_free_charlen (gfc_current_ns
->cl_list
, gfc_current_ns
->old_cl_list
);
2410 gfc_current_ns
->cl_list
= gfc_current_ns
->old_cl_list
;
2412 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
2413 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
2415 gfc_reject_data (gfc_current_ns
);
2417 gfc_new_block
= NULL
;
2418 gfc_undo_symbols ();
2419 gfc_clear_warning ();
2420 undo_new_statement ();
2424 /* Generic complaint about an out of order statement. We also do
2425 whatever is necessary to clean up. */
2428 unexpected_statement (gfc_statement st
)
2430 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
2432 reject_statement ();
2436 /* Given the next statement seen by the matcher, make sure that it is
2437 in proper order with the last. This subroutine is initialized by
2438 calling it with an argument of ST_NONE. If there is a problem, we
2439 issue an error and return false. Otherwise we return true.
2441 Individual parsers need to verify that the statements seen are
2442 valid before calling here, i.e., ENTRY statements are not allowed in
2443 INTERFACE blocks. The following diagram is taken from the standard:
2445 +---------------------------------------+
2446 | program subroutine function module |
2447 +---------------------------------------+
2449 +---------------------------------------+
2451 +---------------------------------------+
2453 | +-----------+------------------+
2454 | | parameter | implicit |
2455 | +-----------+------------------+
2456 | format | | derived type |
2457 | entry | parameter | interface |
2458 | | data | specification |
2459 | | | statement func |
2460 | +-----------+------------------+
2461 | | data | executable |
2462 +--------+-----------+------------------+
2464 +---------------------------------------+
2465 | internal module/subprogram |
2466 +---------------------------------------+
2468 +---------------------------------------+
2477 ORDER_IMPLICIT_NONE
,
2485 enum state_order state
;
2486 gfc_statement last_statement
;
2492 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
2498 p
->state
= ORDER_START
;
2502 if (p
->state
> ORDER_USE
)
2504 p
->state
= ORDER_USE
;
2508 if (p
->state
> ORDER_IMPORT
)
2510 p
->state
= ORDER_IMPORT
;
2513 case ST_IMPLICIT_NONE
:
2514 if (p
->state
> ORDER_IMPLICIT
)
2517 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2518 statement disqualifies a USE but not an IMPLICIT NONE.
2519 Duplicate IMPLICIT NONEs are caught when the implicit types
2522 p
->state
= ORDER_IMPLICIT_NONE
;
2526 if (p
->state
> ORDER_IMPLICIT
)
2528 p
->state
= ORDER_IMPLICIT
;
2533 if (p
->state
< ORDER_IMPLICIT_NONE
)
2534 p
->state
= ORDER_IMPLICIT_NONE
;
2538 if (p
->state
>= ORDER_EXEC
)
2540 if (p
->state
< ORDER_IMPLICIT
)
2541 p
->state
= ORDER_IMPLICIT
;
2545 if (p
->state
< ORDER_SPEC
)
2546 p
->state
= ORDER_SPEC
;
2551 case ST_STRUCTURE_DECL
:
2552 case ST_DERIVED_DECL
:
2554 if (p
->state
>= ORDER_EXEC
)
2556 if (p
->state
< ORDER_SPEC
)
2557 p
->state
= ORDER_SPEC
;
2561 /* The OpenMP directives have to be somewhere in the specification
2562 part, but there are no further requirements on their ordering.
2563 Thus don't adjust p->state, just ignore them. */
2564 if (p
->state
>= ORDER_EXEC
)
2570 if (p
->state
< ORDER_EXEC
)
2571 p
->state
= ORDER_EXEC
;
2578 /* All is well, record the statement in case we need it next time. */
2579 p
->where
= gfc_current_locus
;
2580 p
->last_statement
= st
;
2585 gfc_error ("%s statement at %C cannot follow %s statement at %L",
2586 gfc_ascii_statement (st
),
2587 gfc_ascii_statement (p
->last_statement
), &p
->where
);
2593 /* Handle an unexpected end of file. This is a show-stopper... */
2595 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
2598 unexpected_eof (void)
2602 gfc_error ("Unexpected end of file in %qs", gfc_source_file
);
2604 /* Memory cleanup. Move to "second to last". */
2605 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
2608 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
2611 longjmp (eof_buf
, 1);
2615 /* Parse the CONTAINS section of a derived type definition. */
2617 gfc_access gfc_typebound_default_access
;
2620 parse_derived_contains (void)
2623 bool seen_private
= false;
2624 bool seen_comps
= false;
2625 bool error_flag
= false;
2628 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2629 gcc_assert (gfc_current_block ());
2631 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
2633 if (gfc_current_block ()->attr
.sequence
)
2634 gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
2635 " section at %C", gfc_current_block ()->name
);
2636 if (gfc_current_block ()->attr
.is_bind_c
)
2637 gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
2638 " section at %C", gfc_current_block ()->name
);
2640 accept_statement (ST_CONTAINS
);
2641 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
2643 gfc_typebound_default_access
= ACCESS_PUBLIC
;
2649 st
= next_statement ();
2657 gfc_error ("Components in TYPE at %C must precede CONTAINS");
2661 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
2664 accept_statement (ST_PROCEDURE
);
2669 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
2672 accept_statement (ST_GENERIC
);
2677 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
2681 accept_statement (ST_FINAL
);
2689 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
2690 "at %C with empty CONTAINS section")))
2693 /* ST_END_TYPE is accepted by parse_derived after return. */
2697 if (!gfc_find_state (COMP_MODULE
))
2699 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2706 gfc_error ("PRIVATE statement at %C must precede procedure"
2713 gfc_error ("Duplicate PRIVATE statement at %C");
2717 accept_statement (ST_PRIVATE
);
2718 gfc_typebound_default_access
= ACCESS_PRIVATE
;
2719 seen_private
= true;
2723 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2727 gfc_error ("Already inside a CONTAINS block at %C");
2731 unexpected_statement (st
);
2739 reject_statement ();
2743 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2749 /* Set attributes for the parent symbol based on the attributes of a component
2750 and raise errors if conflicting attributes are found for the component. */
2753 check_component (gfc_symbol
*sym
, gfc_component
*c
, gfc_component
**lockp
,
2754 gfc_component
**eventp
)
2756 bool coarray
, lock_type
, event_type
, allocatable
, pointer
;
2757 coarray
= lock_type
= event_type
= allocatable
= pointer
= false;
2758 gfc_component
*lock_comp
= NULL
, *event_comp
= NULL
;
2760 if (lockp
) lock_comp
= *lockp
;
2761 if (eventp
) event_comp
= *eventp
;
2763 /* Look for allocatable components. */
2764 if (c
->attr
.allocatable
2765 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2766 && CLASS_DATA (c
)->attr
.allocatable
)
2767 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
2768 && c
->ts
.u
.derived
->attr
.alloc_comp
))
2771 sym
->attr
.alloc_comp
= 1;
2774 /* Look for pointer components. */
2776 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2777 && CLASS_DATA (c
)->attr
.class_pointer
)
2778 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
2781 sym
->attr
.pointer_comp
= 1;
2784 /* Look for procedure pointer components. */
2785 if (c
->attr
.proc_pointer
2786 || (c
->ts
.type
== BT_DERIVED
2787 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
2788 sym
->attr
.proc_pointer_comp
= 1;
2790 /* Looking for coarray components. */
2791 if (c
->attr
.codimension
2792 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2793 && CLASS_DATA (c
)->attr
.codimension
))
2796 sym
->attr
.coarray_comp
= 1;
2799 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
2800 && !c
->attr
.pointer
)
2803 sym
->attr
.coarray_comp
= 1;
2806 /* Looking for lock_type components. */
2807 if ((c
->ts
.type
== BT_DERIVED
2808 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2809 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2810 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2811 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2812 == INTMOD_ISO_FORTRAN_ENV
2813 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2814 == ISOFORTRAN_LOCK_TYPE
)
2815 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
2816 && !allocatable
&& !pointer
))
2820 sym
->attr
.lock_comp
= 1;
2823 /* Looking for event_type components. */
2824 if ((c
->ts
.type
== BT_DERIVED
2825 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2826 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2827 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2828 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2829 == INTMOD_ISO_FORTRAN_ENV
2830 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2831 == ISOFORTRAN_EVENT_TYPE
)
2832 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.event_comp
2833 && !allocatable
&& !pointer
))
2837 sym
->attr
.event_comp
= 1;
2840 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2841 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2842 unless there are nondirect [allocatable or pointer] components
2843 involved (cf. 1.3.33.1 and 1.3.33.3). */
2845 if (pointer
&& !coarray
&& lock_type
)
2846 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2847 "codimension or be a subcomponent of a coarray, "
2848 "which is not possible as the component has the "
2849 "pointer attribute", c
->name
, &c
->loc
);
2850 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
2851 && c
->ts
.u
.derived
->attr
.lock_comp
)
2852 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2853 "of type LOCK_TYPE, which must have a codimension or be a "
2854 "subcomponent of a coarray", c
->name
, &c
->loc
);
2856 if (lock_type
&& allocatable
&& !coarray
)
2857 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
2858 "a codimension", c
->name
, &c
->loc
);
2859 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
2860 && c
->ts
.u
.derived
->attr
.lock_comp
)
2861 gfc_error ("Allocatable component %s at %L must have a codimension as "
2862 "it has a noncoarray subcomponent of type LOCK_TYPE",
2865 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
2866 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2867 "subcomponent of type LOCK_TYPE must have a codimension or "
2868 "be a subcomponent of a coarray. (Variables of type %s may "
2869 "not have a codimension as already a coarray "
2870 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
2872 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
2873 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2874 "subcomponent of type LOCK_TYPE must have a codimension or "
2875 "be a subcomponent of a coarray. (Variables of type %s may "
2876 "not have a codimension as %s at %L has a codimension or a "
2877 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
2878 sym
->name
, c
->name
, &c
->loc
);
2880 /* Similarly for EVENT TYPE. */
2882 if (pointer
&& !coarray
&& event_type
)
2883 gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
2884 "codimension or be a subcomponent of a coarray, "
2885 "which is not possible as the component has the "
2886 "pointer attribute", c
->name
, &c
->loc
);
2887 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
2888 && c
->ts
.u
.derived
->attr
.event_comp
)
2889 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2890 "of type EVENT_TYPE, which must have a codimension or be a "
2891 "subcomponent of a coarray", c
->name
, &c
->loc
);
2893 if (event_type
&& allocatable
&& !coarray
)
2894 gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
2895 "a codimension", c
->name
, &c
->loc
);
2896 else if (event_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
2897 && c
->ts
.u
.derived
->attr
.event_comp
)
2898 gfc_error ("Allocatable component %s at %L must have a codimension as "
2899 "it has a noncoarray subcomponent of type EVENT_TYPE",
2902 if (sym
->attr
.coarray_comp
&& !coarray
&& event_type
)
2903 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
2904 "subcomponent of type EVENT_TYPE must have a codimension or "
2905 "be a subcomponent of a coarray. (Variables of type %s may "
2906 "not have a codimension as already a coarray "
2907 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
2909 if (sym
->attr
.event_comp
&& coarray
&& !event_type
)
2910 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
2911 "subcomponent of type EVENT_TYPE must have a codimension or "
2912 "be a subcomponent of a coarray. (Variables of type %s may "
2913 "not have a codimension as %s at %L has a codimension or a "
2914 "coarray subcomponent)", event_comp
->name
, &event_comp
->loc
,
2915 sym
->name
, c
->name
, &c
->loc
);
2917 /* Look for private components. */
2918 if (sym
->component_access
== ACCESS_PRIVATE
2919 || c
->attr
.access
== ACCESS_PRIVATE
2920 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
2921 sym
->attr
.private_comp
= 1;
2923 if (lockp
) *lockp
= lock_comp
;
2924 if (eventp
) *eventp
= event_comp
;
2928 static void parse_struct_map (gfc_statement
);
2930 /* Parse a union component definition within a structure definition. */
2938 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
2941 accept_statement(ST_UNION
);
2942 push_state (&s
, COMP_UNION
, gfc_new_block
);
2949 st
= next_statement ();
2950 /* Only MAP declarations valid within a union. */
2957 accept_statement (ST_MAP
);
2958 parse_struct_map (ST_MAP
);
2959 /* Add a component to the union for each map. */
2960 if (!gfc_add_component (un
, gfc_new_block
->name
, &c
))
2962 gfc_internal_error ("failed to create map component '%s'",
2963 gfc_new_block
->name
);
2964 reject_statement ();
2967 c
->ts
.type
= BT_DERIVED
;
2968 c
->ts
.u
.derived
= gfc_new_block
;
2969 /* Normally components get their initialization expressions when they
2970 are created in decl.c (build_struct) so we can look through the
2971 flat component list for initializers during resolution. Unions and
2972 maps create components along with their type definitions so we
2973 have to generate initializers here. */
2974 c
->initializer
= gfc_default_initializer (&c
->ts
);
2979 accept_statement (ST_END_UNION
);
2983 unexpected_statement (st
);
2988 for (c
= un
->components
; c
; c
= c
->next
)
2989 check_component (un
, c
, &lock_comp
, &event_comp
);
2991 /* Add the union as a component in its parent structure. */
2993 if (!gfc_add_component (gfc_current_block (), un
->name
, &c
))
2995 gfc_internal_error ("failed to create union component '%s'", un
->name
);
2996 reject_statement ();
2999 c
->ts
.type
= BT_UNION
;
3000 c
->ts
.u
.derived
= un
;
3001 c
->initializer
= gfc_default_initializer (&c
->ts
);
3003 un
->attr
.zero_comp
= un
->components
== NULL
;
3007 /* Parse a STRUCTURE or MAP. */
3010 parse_struct_map (gfc_statement block
)
3016 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3017 gfc_compile_state comp
;
3020 if (block
== ST_STRUCTURE_DECL
)
3022 comp
= COMP_STRUCTURE
;
3023 ends
= ST_END_STRUCTURE
;
3027 gcc_assert (block
== ST_MAP
);
3032 accept_statement(block
);
3033 push_state (&s
, comp
, gfc_new_block
);
3035 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3038 while (compiling_type
)
3040 st
= next_statement ();
3046 /* Nested structure declarations will be captured as ST_DATA_DECL. */
3047 case ST_STRUCTURE_DECL
:
3048 /* Let a more specific error make it to decode_statement(). */
3049 if (gfc_error_check () == 0)
3050 gfc_error ("Syntax error in nested structure declaration at %C");
3051 reject_statement ();
3052 /* Skip the rest of this statement. */
3053 gfc_error_recovery ();
3057 accept_statement (ST_UNION
);
3062 /* The data declaration was a nested/ad-hoc STRUCTURE field. */
3063 accept_statement (ST_DATA_DECL
);
3064 if (gfc_new_block
&& gfc_new_block
!= gfc_current_block ()
3065 && gfc_new_block
->attr
.flavor
== FL_STRUCT
)
3066 parse_struct_map (ST_STRUCTURE_DECL
);
3069 case ST_END_STRUCTURE
:
3073 accept_statement (st
);
3077 unexpected_statement (st
);
3081 unexpected_statement (st
);
3086 /* Validate each component. */
3087 sym
= gfc_current_block ();
3088 for (c
= sym
->components
; c
; c
= c
->next
)
3089 check_component (sym
, c
, &lock_comp
, &event_comp
);
3091 sym
->attr
.zero_comp
= (sym
->components
== NULL
);
3093 /* Allow parse_union to find this structure to add to its list of maps. */
3094 if (block
== ST_MAP
)
3095 gfc_new_block
= gfc_current_block ();
3101 /* Parse a derived type. */
3104 parse_derived (void)
3106 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
3110 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3112 accept_statement (ST_DERIVED_DECL
);
3113 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
3115 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3122 while (compiling_type
)
3124 st
= next_statement ();
3132 accept_statement (st
);
3137 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
3144 if (!seen_component
)
3145 gfc_notify_std (GFC_STD_F2003
, "Derived type "
3146 "definition at %C without components");
3148 accept_statement (ST_END_TYPE
);
3152 if (!gfc_find_state (COMP_MODULE
))
3154 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3161 gfc_error ("PRIVATE statement at %C must precede "
3162 "structure components");
3167 gfc_error ("Duplicate PRIVATE statement at %C");
3169 s
.sym
->component_access
= ACCESS_PRIVATE
;
3171 accept_statement (ST_PRIVATE
);
3178 gfc_error ("SEQUENCE statement at %C must precede "
3179 "structure components");
3183 if (gfc_current_block ()->attr
.sequence
)
3184 gfc_warning (0, "SEQUENCE attribute at %C already specified in "
3189 gfc_error ("Duplicate SEQUENCE statement at %C");
3193 gfc_add_sequence (&gfc_current_block ()->attr
,
3194 gfc_current_block ()->name
, NULL
);
3198 gfc_notify_std (GFC_STD_F2003
,
3199 "CONTAINS block in derived type"
3200 " definition at %C");
3202 accept_statement (ST_CONTAINS
);
3203 parse_derived_contains ();
3207 unexpected_statement (st
);
3212 /* need to verify that all fields of the derived type are
3213 * interoperable with C if the type is declared to be bind(c)
3215 sym
= gfc_current_block ();
3216 for (c
= sym
->components
; c
; c
= c
->next
)
3217 check_component (sym
, c
, &lock_comp
, &event_comp
);
3219 if (!seen_component
)
3220 sym
->attr
.zero_comp
= 1;
3226 /* Parse an ENUM. */
3234 int seen_enumerator
= 0;
3236 push_state (&s
, COMP_ENUM
, gfc_new_block
);
3240 while (compiling_enum
)
3242 st
= next_statement ();
3250 seen_enumerator
= 1;
3251 accept_statement (st
);
3256 if (!seen_enumerator
)
3257 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
3258 accept_statement (st
);
3262 gfc_free_enum_history ();
3263 unexpected_statement (st
);
3271 /* Parse an interface. We must be able to deal with the possibility
3272 of recursive interfaces. The parse_spec() subroutine is mutually
3273 recursive with parse_interface(). */
3275 static gfc_statement
parse_spec (gfc_statement
);
3278 parse_interface (void)
3280 gfc_compile_state new_state
= COMP_NONE
, current_state
;
3281 gfc_symbol
*prog_unit
, *sym
;
3282 gfc_interface_info save
;
3283 gfc_state_data s1
, s2
;
3286 accept_statement (ST_INTERFACE
);
3288 current_interface
.ns
= gfc_current_ns
;
3289 save
= current_interface
;
3291 sym
= (current_interface
.type
== INTERFACE_GENERIC
3292 || current_interface
.type
== INTERFACE_USER_OP
)
3293 ? gfc_new_block
: NULL
;
3295 push_state (&s1
, COMP_INTERFACE
, sym
);
3296 current_state
= COMP_NONE
;
3299 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
3301 st
= next_statement ();
3309 if (st
== ST_SUBROUTINE
)
3310 new_state
= COMP_SUBROUTINE
;
3311 else if (st
== ST_FUNCTION
)
3312 new_state
= COMP_FUNCTION
;
3313 if (gfc_new_block
->attr
.pointer
)
3315 gfc_new_block
->attr
.pointer
= 0;
3316 gfc_new_block
->attr
.proc_pointer
= 1;
3318 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
3319 gfc_new_block
->formal
, NULL
))
3321 reject_statement ();
3322 gfc_free_namespace (gfc_current_ns
);
3325 /* F2008 C1210 forbids the IMPORT statement in module procedure
3326 interface bodies and the flag is set to import symbols. */
3327 if (gfc_new_block
->attr
.module_procedure
)
3328 gfc_current_ns
->has_import_set
= 1;
3332 case ST_MODULE_PROC
: /* The module procedure matcher makes
3333 sure the context is correct. */
3334 accept_statement (st
);
3335 gfc_free_namespace (gfc_current_ns
);
3338 case ST_END_INTERFACE
:
3339 gfc_free_namespace (gfc_current_ns
);
3340 gfc_current_ns
= current_interface
.ns
;
3344 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
3345 gfc_ascii_statement (st
));
3346 reject_statement ();
3347 gfc_free_namespace (gfc_current_ns
);
3352 /* Make sure that the generic name has the right attribute. */
3353 if (current_interface
.type
== INTERFACE_GENERIC
3354 && current_state
== COMP_NONE
)
3356 if (new_state
== COMP_FUNCTION
&& sym
)
3357 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
3358 else if (new_state
== COMP_SUBROUTINE
&& sym
)
3359 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
3361 current_state
= new_state
;
3364 if (current_interface
.type
== INTERFACE_ABSTRACT
)
3366 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
3367 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
3368 gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
3369 "cannot be the same as an intrinsic type",
3370 gfc_new_block
->name
);
3373 push_state (&s2
, new_state
, gfc_new_block
);
3374 accept_statement (st
);
3375 prog_unit
= gfc_new_block
;
3376 prog_unit
->formal_ns
= gfc_current_ns
;
3377 if (prog_unit
== prog_unit
->formal_ns
->proc_name
3378 && prog_unit
->ns
!= prog_unit
->formal_ns
)
3382 /* Read data declaration statements. */
3383 st
= parse_spec (ST_NONE
);
3384 in_specification_block
= true;
3386 /* Since the interface block does not permit an IMPLICIT statement,
3387 the default type for the function or the result must be taken
3388 from the formal namespace. */
3389 if (new_state
== COMP_FUNCTION
)
3391 if (prog_unit
->result
== prog_unit
3392 && prog_unit
->ts
.type
== BT_UNKNOWN
)
3393 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
3394 else if (prog_unit
->result
!= prog_unit
3395 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
3396 gfc_set_default_type (prog_unit
->result
, 1,
3397 prog_unit
->formal_ns
);
3400 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
3402 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
3403 gfc_ascii_statement (st
));
3404 reject_statement ();
3408 /* Add EXTERNAL attribute to function or subroutine. */
3409 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
3410 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
3412 current_interface
= save
;
3413 gfc_add_interface (prog_unit
);
3416 if (current_interface
.ns
3417 && current_interface
.ns
->proc_name
3418 && strcmp (current_interface
.ns
->proc_name
->name
,
3419 prog_unit
->name
) == 0)
3420 gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
3421 "enclosing procedure", prog_unit
->name
,
3422 ¤t_interface
.ns
->proc_name
->declared_at
);
3431 /* Associate function characteristics by going back to the function
3432 declaration and rematching the prefix. */
3435 match_deferred_characteristics (gfc_typespec
* ts
)
3438 match m
= MATCH_ERROR
;
3439 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3441 loc
= gfc_current_locus
;
3443 gfc_current_locus
= gfc_current_block ()->declared_at
;
3446 gfc_buffer_error (true);
3447 m
= gfc_match_prefix (ts
);
3448 gfc_buffer_error (false);
3450 if (ts
->type
== BT_DERIVED
)
3458 /* Only permit one go at the characteristic association. */
3462 /* Set the function locus correctly. If we have not found the
3463 function name, there is an error. */
3465 && gfc_match ("function% %n", name
) == MATCH_YES
3466 && strcmp (name
, gfc_current_block ()->name
) == 0)
3468 gfc_current_block ()->declared_at
= gfc_current_locus
;
3469 gfc_commit_symbols ();
3474 gfc_undo_symbols ();
3477 gfc_current_locus
=loc
;
3482 /* Check specification-expressions in the function result of the currently
3483 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
3484 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
3485 scope are not yet parsed so this has to be delayed up to parse_spec. */
3488 check_function_result_typed (void)
3492 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
3494 if (!gfc_current_ns
->proc_name
->result
) return;
3496 ts
= gfc_current_ns
->proc_name
->result
->ts
;
3498 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
3499 /* TODO: Extend when KIND type parameters are implemented. */
3500 if (ts
.type
== BT_CHARACTER
&& ts
.u
.cl
&& ts
.u
.cl
->length
)
3501 gfc_expr_check_typed (ts
.u
.cl
->length
, gfc_current_ns
, true);
3505 /* Parse a set of specification statements. Returns the statement
3506 that doesn't fit. */
3508 static gfc_statement
3509 parse_spec (gfc_statement st
)
3512 bool function_result_typed
= false;
3513 bool bad_characteristic
= false;
3516 in_specification_block
= true;
3518 verify_st_order (&ss
, ST_NONE
, false);
3520 st
= next_statement ();
3522 /* If we are not inside a function or don't have a result specified so far,
3523 do nothing special about it. */
3524 if (gfc_current_state () != COMP_FUNCTION
)
3525 function_result_typed
= true;
3528 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
3531 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
3532 function_result_typed
= true;
3537 /* If we're inside a BLOCK construct, some statements are disallowed.
3538 Check this here. Attribute declaration statements like INTENT, OPTIONAL
3539 or VALUE are also disallowed, but they don't have a particular ST_*
3540 key so we have to check for them individually in their matcher routine. */
3541 if (gfc_current_state () == COMP_BLOCK
)
3545 case ST_IMPLICIT_NONE
:
3548 case ST_EQUIVALENCE
:
3549 case ST_STATEMENT_FUNCTION
:
3550 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
3551 gfc_ascii_statement (st
));
3552 reject_statement ();
3558 else if (gfc_current_state () == COMP_BLOCK_DATA
)
3559 /* Fortran 2008, C1116. */
3566 case ST_END_BLOCK_DATA
:
3568 case ST_EQUIVALENCE
:
3571 case ST_IMPLICIT_NONE
:
3572 case ST_DERIVED_DECL
:
3580 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
3581 gfc_ascii_statement (st
));
3582 reject_statement ();
3586 /* If we find a statement that can not be followed by an IMPLICIT statement
3587 (and thus we can expect to see none any further), type the function result
3588 if it has not yet been typed. Be careful not to give the END statement
3589 to verify_st_order! */
3590 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
3592 bool verify_now
= false;
3594 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
3599 verify_st_order (&dummyss
, ST_NONE
, false);
3600 verify_st_order (&dummyss
, st
, false);
3602 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
3608 check_function_result_typed ();
3609 function_result_typed
= true;
3618 case ST_IMPLICIT_NONE
:
3620 if (!function_result_typed
)
3622 check_function_result_typed ();
3623 function_result_typed
= true;
3629 case ST_DATA
: /* Not allowed in interfaces */
3630 if (gfc_current_state () == COMP_INTERFACE
)
3640 case ST_STRUCTURE_DECL
:
3641 case ST_DERIVED_DECL
:
3645 if (!verify_st_order (&ss
, st
, false))
3647 reject_statement ();
3648 st
= next_statement ();
3658 case ST_STRUCTURE_DECL
:
3659 parse_struct_map (ST_STRUCTURE_DECL
);
3662 case ST_DERIVED_DECL
:
3668 if (gfc_current_state () != COMP_MODULE
)
3670 gfc_error ("%s statement must appear in a MODULE",
3671 gfc_ascii_statement (st
));
3672 reject_statement ();
3676 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
3678 gfc_error ("%s statement at %C follows another accessibility "
3679 "specification", gfc_ascii_statement (st
));
3680 reject_statement ();
3684 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
3685 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3689 case ST_STATEMENT_FUNCTION
:
3690 if (gfc_current_state () == COMP_MODULE
3691 || gfc_current_state () == COMP_SUBMODULE
)
3693 unexpected_statement (st
);
3701 accept_statement (st
);
3702 st
= next_statement ();
3706 accept_statement (st
);
3708 st
= next_statement ();
3711 case ST_GET_FCN_CHARACTERISTICS
:
3712 /* This statement triggers the association of a function's result
3714 ts
= &gfc_current_block ()->result
->ts
;
3715 if (match_deferred_characteristics (ts
) != MATCH_YES
)
3716 bad_characteristic
= true;
3718 st
= next_statement ();
3725 /* If match_deferred_characteristics failed, then there is an error. */
3726 if (bad_characteristic
)
3728 ts
= &gfc_current_block ()->result
->ts
;
3729 if (ts
->type
!= BT_DERIVED
)
3730 gfc_error ("Bad kind expression for function %qs at %L",
3731 gfc_current_block ()->name
,
3732 &gfc_current_block ()->declared_at
);
3734 gfc_error ("The type for function %qs at %L is not accessible",
3735 gfc_current_block ()->name
,
3736 &gfc_current_block ()->declared_at
);
3738 gfc_current_block ()->ts
.kind
= 0;
3739 /* Keep the derived type; if it's bad, it will be discovered later. */
3740 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
3741 ts
->type
= BT_UNKNOWN
;
3744 in_specification_block
= false;
3750 /* Parse a WHERE block, (not a simple WHERE statement). */
3753 parse_where_block (void)
3755 int seen_empty_else
;
3760 accept_statement (ST_WHERE_BLOCK
);
3761 top
= gfc_state_stack
->tail
;
3763 push_state (&s
, COMP_WHERE
, gfc_new_block
);
3765 d
= add_statement ();
3766 d
->expr1
= top
->expr1
;
3772 seen_empty_else
= 0;
3776 st
= next_statement ();
3782 case ST_WHERE_BLOCK
:
3783 parse_where_block ();
3788 accept_statement (st
);
3792 if (seen_empty_else
)
3794 gfc_error ("ELSEWHERE statement at %C follows previous "
3795 "unmasked ELSEWHERE");
3796 reject_statement ();
3800 if (new_st
.expr1
== NULL
)
3801 seen_empty_else
= 1;
3803 d
= new_level (gfc_state_stack
->head
);
3805 d
->expr1
= new_st
.expr1
;
3807 accept_statement (st
);
3812 accept_statement (st
);
3816 gfc_error ("Unexpected %s statement in WHERE block at %C",
3817 gfc_ascii_statement (st
));
3818 reject_statement ();
3822 while (st
!= ST_END_WHERE
);
3828 /* Parse a FORALL block (not a simple FORALL statement). */
3831 parse_forall_block (void)
3837 accept_statement (ST_FORALL_BLOCK
);
3838 top
= gfc_state_stack
->tail
;
3840 push_state (&s
, COMP_FORALL
, gfc_new_block
);
3842 d
= add_statement ();
3843 d
->op
= EXEC_FORALL
;
3848 st
= next_statement ();
3853 case ST_POINTER_ASSIGNMENT
:
3856 accept_statement (st
);
3859 case ST_WHERE_BLOCK
:
3860 parse_where_block ();
3863 case ST_FORALL_BLOCK
:
3864 parse_forall_block ();
3868 accept_statement (st
);
3875 gfc_error ("Unexpected %s statement in FORALL block at %C",
3876 gfc_ascii_statement (st
));
3878 reject_statement ();
3882 while (st
!= ST_END_FORALL
);
3888 static gfc_statement
parse_executable (gfc_statement
);
3890 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
3893 parse_if_block (void)
3902 accept_statement (ST_IF_BLOCK
);
3904 top
= gfc_state_stack
->tail
;
3905 push_state (&s
, COMP_IF
, gfc_new_block
);
3907 new_st
.op
= EXEC_IF
;
3908 d
= add_statement ();
3910 d
->expr1
= top
->expr1
;
3916 st
= parse_executable (ST_NONE
);
3926 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
3927 "statement at %L", &else_locus
);
3929 reject_statement ();
3933 d
= new_level (gfc_state_stack
->head
);
3935 d
->expr1
= new_st
.expr1
;
3937 accept_statement (st
);
3944 gfc_error ("Duplicate ELSE statements at %L and %C",
3946 reject_statement ();
3951 else_locus
= gfc_current_locus
;
3953 d
= new_level (gfc_state_stack
->head
);
3956 accept_statement (st
);
3964 unexpected_statement (st
);
3968 while (st
!= ST_ENDIF
);
3971 accept_statement (st
);
3975 /* Parse a SELECT block. */
3978 parse_select_block (void)
3984 accept_statement (ST_SELECT_CASE
);
3986 cp
= gfc_state_stack
->tail
;
3987 push_state (&s
, COMP_SELECT
, gfc_new_block
);
3989 /* Make sure that the next statement is a CASE or END SELECT. */
3992 st
= next_statement ();
3995 if (st
== ST_END_SELECT
)
3997 /* Empty SELECT CASE is OK. */
3998 accept_statement (st
);
4005 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
4008 reject_statement ();
4011 /* At this point, we're got a nonempty select block. */
4012 cp
= new_level (cp
);
4015 accept_statement (st
);
4019 st
= parse_executable (ST_NONE
);
4026 cp
= new_level (gfc_state_stack
->head
);
4028 gfc_clear_new_st ();
4030 accept_statement (st
);
4036 /* Can't have an executable statement because of
4037 parse_executable(). */
4039 unexpected_statement (st
);
4043 while (st
!= ST_END_SELECT
);
4046 accept_statement (st
);
4050 /* Pop the current selector from the SELECT TYPE stack. */
4053 select_type_pop (void)
4055 gfc_select_type_stack
*old
= select_type_stack
;
4056 select_type_stack
= old
->prev
;
4061 /* Parse a SELECT TYPE construct (F03:R821). */
4064 parse_select_type_block (void)
4070 accept_statement (ST_SELECT_TYPE
);
4072 cp
= gfc_state_stack
->tail
;
4073 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
4075 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
4079 st
= next_statement ();
4082 if (st
== ST_END_SELECT
)
4083 /* Empty SELECT CASE is OK. */
4085 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
4088 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
4089 "following SELECT TYPE at %C");
4091 reject_statement ();
4094 /* At this point, we're got a nonempty select block. */
4095 cp
= new_level (cp
);
4098 accept_statement (st
);
4102 st
= parse_executable (ST_NONE
);
4110 cp
= new_level (gfc_state_stack
->head
);
4112 gfc_clear_new_st ();
4114 accept_statement (st
);
4120 /* Can't have an executable statement because of
4121 parse_executable(). */
4123 unexpected_statement (st
);
4127 while (st
!= ST_END_SELECT
);
4131 accept_statement (st
);
4132 gfc_current_ns
= gfc_current_ns
->parent
;
4137 /* Given a symbol, make sure it is not an iteration variable for a DO
4138 statement. This subroutine is called when the symbol is seen in a
4139 context that causes it to become redefined. If the symbol is an
4140 iterator, we generate an error message and return nonzero. */
4143 gfc_check_do_variable (gfc_symtree
*st
)
4147 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
4148 if (s
->do_variable
== st
)
4150 gfc_error_now ("Variable %qs at %C cannot be redefined inside "
4151 "loop beginning at %L", st
->name
, &s
->head
->loc
);
4159 /* Checks to see if the current statement label closes an enddo.
4160 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
4161 an error) if it incorrectly closes an ENDDO. */
4164 check_do_closure (void)
4168 if (gfc_statement_label
== NULL
)
4171 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
4172 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4176 return 0; /* No loops to close */
4178 if (p
->ext
.end_do_label
== gfc_statement_label
)
4180 if (p
== gfc_state_stack
)
4183 gfc_error ("End of nonblock DO statement at %C is within another block");
4187 /* At this point, the label doesn't terminate the innermost loop.
4188 Make sure it doesn't terminate another one. */
4189 for (; p
; p
= p
->previous
)
4190 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4191 && p
->ext
.end_do_label
== gfc_statement_label
)
4193 gfc_error ("End of nonblock DO statement at %C is interwoven "
4194 "with another DO loop");
4202 /* Parse a series of contained program units. */
4204 static void parse_progunit (gfc_statement
);
4207 /* Parse a CRITICAL block. */
4210 parse_critical_block (void)
4213 gfc_state_data s
, *sd
;
4216 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4217 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
4218 gfc_error_now (is_oacc (sd
)
4219 ? "CRITICAL block inside of OpenACC region at %C"
4220 : "CRITICAL block inside of OpenMP region at %C");
4222 s
.ext
.end_do_label
= new_st
.label1
;
4224 accept_statement (ST_CRITICAL
);
4225 top
= gfc_state_stack
->tail
;
4227 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
4229 d
= add_statement ();
4230 d
->op
= EXEC_CRITICAL
;
4235 st
= parse_executable (ST_NONE
);
4243 case ST_END_CRITICAL
:
4244 if (s
.ext
.end_do_label
!= NULL
4245 && s
.ext
.end_do_label
!= gfc_statement_label
)
4246 gfc_error_now ("Statement label in END CRITICAL at %C does not "
4247 "match CRITICAL label");
4249 if (gfc_statement_label
!= NULL
)
4251 new_st
.op
= EXEC_NOP
;
4257 unexpected_statement (st
);
4261 while (st
!= ST_END_CRITICAL
);
4264 accept_statement (st
);
4268 /* Set up the local namespace for a BLOCK construct. */
4271 gfc_build_block_ns (gfc_namespace
*parent_ns
)
4273 gfc_namespace
* my_ns
;
4274 static int numblock
= 1;
4276 my_ns
= gfc_get_namespace (parent_ns
, 1);
4277 my_ns
->construct_entities
= 1;
4279 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
4280 code generation (so it must not be NULL).
4281 We set its recursive argument if our container procedure is recursive, so
4282 that local variables are accordingly placed on the stack when it
4283 will be necessary. */
4285 my_ns
->proc_name
= gfc_new_block
;
4289 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
4291 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
4292 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
4293 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
4294 my_ns
->proc_name
->name
, NULL
);
4296 gfc_commit_symbol (my_ns
->proc_name
);
4299 if (parent_ns
->proc_name
)
4300 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
4306 /* Parse a BLOCK construct. */
4309 parse_block_construct (void)
4311 gfc_namespace
* my_ns
;
4312 gfc_namespace
* my_parent
;
4315 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
4317 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4319 new_st
.op
= EXEC_BLOCK
;
4320 new_st
.ext
.block
.ns
= my_ns
;
4321 new_st
.ext
.block
.assoc
= NULL
;
4322 accept_statement (ST_BLOCK
);
4324 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
4325 gfc_current_ns
= my_ns
;
4326 my_parent
= my_ns
->parent
;
4328 parse_progunit (ST_NONE
);
4330 /* Don't depend on the value of gfc_current_ns; it might have been
4331 reset if the block had errors and was cleaned up. */
4332 gfc_current_ns
= my_parent
;
4338 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
4339 behind the scenes with compiler-generated variables. */
4342 parse_associate (void)
4344 gfc_namespace
* my_ns
;
4347 gfc_association_list
* a
;
4349 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
4351 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4353 new_st
.op
= EXEC_BLOCK
;
4354 new_st
.ext
.block
.ns
= my_ns
;
4355 gcc_assert (new_st
.ext
.block
.assoc
);
4357 /* Add all associate-names as BLOCK variables. Creating them is enough
4358 for now, they'll get their values during trans-* phase. */
4359 gfc_current_ns
= my_ns
;
4360 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
4364 gfc_array_ref
*array_ref
;
4366 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
4370 sym
->attr
.flavor
= FL_VARIABLE
;
4372 sym
->declared_at
= a
->where
;
4373 gfc_set_sym_referenced (sym
);
4375 /* Initialize the typespec. It is not available in all cases,
4376 however, as it may only be set on the target during resolution.
4377 Still, sometimes it helps to have it right now -- especially
4378 for parsing component references on the associate-name
4379 in case of association to a derived-type. */
4380 sym
->ts
= a
->target
->ts
;
4382 /* Check if the target expression is array valued. This can not always
4383 be done by looking at target.rank, because that might not have been
4384 set yet. Therefore traverse the chain of refs, looking for the last
4385 array ref and evaluate that. */
4387 for (ref
= a
->target
->ref
; ref
; ref
= ref
->next
)
4388 if (ref
->type
== REF_ARRAY
)
4389 array_ref
= &ref
->u
.ar
;
4390 if (array_ref
|| a
->target
->rank
)
4397 /* Count the dimension, that have a non-scalar extend. */
4398 for (dim
= 0; dim
< array_ref
->dimen
; ++dim
)
4399 if (array_ref
->dimen_type
[dim
] != DIMEN_ELEMENT
4400 && !(array_ref
->dimen_type
[dim
] == DIMEN_UNKNOWN
4401 && array_ref
->end
[dim
] == NULL
4402 && array_ref
->start
[dim
] != NULL
))
4406 rank
= a
->target
->rank
;
4407 /* When the rank is greater than zero then sym will be an array. */
4408 if (sym
->ts
.type
== BT_CLASS
)
4410 if ((!CLASS_DATA (sym
)->as
&& rank
!= 0)
4411 || (CLASS_DATA (sym
)->as
4412 && CLASS_DATA (sym
)->as
->rank
!= rank
))
4414 /* Don't just (re-)set the attr and as in the sym.ts,
4415 because this modifies the target's attr and as. Copy the
4416 data and do a build_class_symbol. */
4417 symbol_attribute attr
= CLASS_DATA (a
->target
)->attr
;
4418 int corank
= gfc_get_corank (a
->target
);
4423 as
= gfc_get_array_spec ();
4424 as
->type
= AS_DEFERRED
;
4426 as
->corank
= corank
;
4427 attr
.dimension
= rank
? 1 : 0;
4428 attr
.codimension
= corank
? 1 : 0;
4433 attr
.dimension
= attr
.codimension
= 0;
4436 type
= CLASS_DATA (sym
)->ts
;
4437 if (!gfc_build_class_symbol (&type
,
4441 sym
->ts
.type
= BT_CLASS
;
4442 sym
->attr
.class_ok
= 1;
4445 sym
->attr
.class_ok
= 1;
4447 else if ((!sym
->as
&& rank
!= 0)
4448 || (sym
->as
&& sym
->as
->rank
!= rank
))
4450 as
= gfc_get_array_spec ();
4451 as
->type
= AS_DEFERRED
;
4453 as
->corank
= gfc_get_corank (a
->target
);
4455 sym
->attr
.dimension
= 1;
4457 sym
->attr
.codimension
= 1;
4462 accept_statement (ST_ASSOCIATE
);
4463 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
4466 st
= parse_executable (ST_NONE
);
4473 accept_statement (st
);
4474 my_ns
->code
= gfc_state_stack
->head
;
4478 unexpected_statement (st
);
4482 gfc_current_ns
= gfc_current_ns
->parent
;
4487 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
4488 handled inside of parse_executable(), because they aren't really
4492 parse_do_block (void)
4501 s
.ext
.end_do_label
= new_st
.label1
;
4503 if (new_st
.ext
.iterator
!= NULL
)
4504 stree
= new_st
.ext
.iterator
->var
->symtree
;
4508 accept_statement (ST_DO
);
4510 top
= gfc_state_stack
->tail
;
4511 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
4514 s
.do_variable
= stree
;
4516 top
->block
= new_level (top
);
4517 top
->block
->op
= EXEC_DO
;
4520 st
= parse_executable (ST_NONE
);
4528 if (s
.ext
.end_do_label
!= NULL
4529 && s
.ext
.end_do_label
!= gfc_statement_label
)
4530 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
4533 if (gfc_statement_label
!= NULL
)
4535 new_st
.op
= EXEC_NOP
;
4540 case ST_IMPLIED_ENDDO
:
4541 /* If the do-stmt of this DO construct has a do-construct-name,
4542 the corresponding end-do must be an end-do-stmt (with a matching
4543 name, but in that case we must have seen ST_ENDDO first).
4544 We only complain about this in pedantic mode. */
4545 if (gfc_current_block () != NULL
)
4546 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
4547 &gfc_current_block()->declared_at
);
4552 unexpected_statement (st
);
4557 accept_statement (st
);
4561 /* Parse the statements of OpenMP do/parallel do. */
4563 static gfc_statement
4564 parse_omp_do (gfc_statement omp_st
)
4570 accept_statement (omp_st
);
4572 cp
= gfc_state_stack
->tail
;
4573 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4574 np
= new_level (cp
);
4580 st
= next_statement ();
4583 else if (st
== ST_DO
)
4586 unexpected_statement (st
);
4590 if (gfc_statement_label
!= NULL
4591 && gfc_state_stack
->previous
!= NULL
4592 && gfc_state_stack
->previous
->state
== COMP_DO
4593 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4601 there should be no !$OMP END DO. */
4603 return ST_IMPLIED_ENDDO
;
4606 check_do_closure ();
4609 st
= next_statement ();
4610 gfc_statement omp_end_st
= ST_OMP_END_DO
;
4613 case ST_OMP_DISTRIBUTE
: omp_end_st
= ST_OMP_END_DISTRIBUTE
; break;
4614 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4615 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4617 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4618 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4620 case ST_OMP_DISTRIBUTE_SIMD
:
4621 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4623 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
4624 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
4625 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
4626 case ST_OMP_PARALLEL_DO_SIMD
:
4627 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
4629 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
4630 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4631 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4633 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4634 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4636 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4637 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4639 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4640 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4642 case ST_OMP_TEAMS_DISTRIBUTE
:
4643 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4645 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4646 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4648 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4649 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4651 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4652 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4654 default: gcc_unreachable ();
4656 if (st
== omp_end_st
)
4658 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
4659 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4661 gcc_assert (new_st
.op
== EXEC_NOP
);
4662 gfc_clear_new_st ();
4663 gfc_commit_symbols ();
4664 gfc_warning_check ();
4665 st
= next_statement ();
4671 /* Parse the statements of OpenMP atomic directive. */
4673 static gfc_statement
4674 parse_omp_oacc_atomic (bool omp_p
)
4676 gfc_statement st
, st_atomic
, st_end_atomic
;
4683 st_atomic
= ST_OMP_ATOMIC
;
4684 st_end_atomic
= ST_OMP_END_ATOMIC
;
4688 st_atomic
= ST_OACC_ATOMIC
;
4689 st_end_atomic
= ST_OACC_END_ATOMIC
;
4691 accept_statement (st_atomic
);
4693 cp
= gfc_state_stack
->tail
;
4694 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4695 np
= new_level (cp
);
4698 count
= 1 + ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4699 == GFC_OMP_ATOMIC_CAPTURE
);
4703 st
= next_statement ();
4706 else if (st
== ST_ASSIGNMENT
)
4708 accept_statement (st
);
4712 unexpected_statement (st
);
4717 st
= next_statement ();
4718 if (st
== st_end_atomic
)
4720 gfc_clear_new_st ();
4721 gfc_commit_symbols ();
4722 gfc_warning_check ();
4723 st
= next_statement ();
4725 else if ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4726 == GFC_OMP_ATOMIC_CAPTURE
)
4727 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
4732 /* Parse the statements of an OpenACC structured block. */
4735 parse_oacc_structured_block (gfc_statement acc_st
)
4737 gfc_statement st
, acc_end_st
;
4739 gfc_state_data s
, *sd
;
4741 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4742 if (sd
->state
== COMP_CRITICAL
)
4743 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4745 accept_statement (acc_st
);
4747 cp
= gfc_state_stack
->tail
;
4748 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4749 np
= new_level (cp
);
4754 case ST_OACC_PARALLEL
:
4755 acc_end_st
= ST_OACC_END_PARALLEL
;
4757 case ST_OACC_KERNELS
:
4758 acc_end_st
= ST_OACC_END_KERNELS
;
4761 acc_end_st
= ST_OACC_END_DATA
;
4763 case ST_OACC_HOST_DATA
:
4764 acc_end_st
= ST_OACC_END_HOST_DATA
;
4772 st
= parse_executable (ST_NONE
);
4775 else if (st
!= acc_end_st
)
4777 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
4778 reject_statement ();
4781 while (st
!= acc_end_st
);
4783 gcc_assert (new_st
.op
== EXEC_NOP
);
4785 gfc_clear_new_st ();
4786 gfc_commit_symbols ();
4787 gfc_warning_check ();
4791 /* Parse the statements of OpenACC loop/parallel loop/kernels loop. */
4793 static gfc_statement
4794 parse_oacc_loop (gfc_statement acc_st
)
4798 gfc_state_data s
, *sd
;
4800 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4801 if (sd
->state
== COMP_CRITICAL
)
4802 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4804 accept_statement (acc_st
);
4806 cp
= gfc_state_stack
->tail
;
4807 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4808 np
= new_level (cp
);
4814 st
= next_statement ();
4817 else if (st
== ST_DO
)
4821 gfc_error ("Expected DO loop at %C");
4822 reject_statement ();
4827 if (gfc_statement_label
!= NULL
4828 && gfc_state_stack
->previous
!= NULL
4829 && gfc_state_stack
->previous
->state
== COMP_DO
4830 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4833 return ST_IMPLIED_ENDDO
;
4836 check_do_closure ();
4839 st
= next_statement ();
4840 if (st
== ST_OACC_END_LOOP
)
4841 gfc_warning (0, "Redundant !$ACC END LOOP at %C");
4842 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
4843 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
4844 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
4846 gcc_assert (new_st
.op
== EXEC_NOP
);
4847 gfc_clear_new_st ();
4848 gfc_commit_symbols ();
4849 gfc_warning_check ();
4850 st
= next_statement ();
4856 /* Parse the statements of an OpenMP structured block. */
4859 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
4861 gfc_statement st
, omp_end_st
;
4865 accept_statement (omp_st
);
4867 cp
= gfc_state_stack
->tail
;
4868 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4869 np
= new_level (cp
);
4875 case ST_OMP_PARALLEL
:
4876 omp_end_st
= ST_OMP_END_PARALLEL
;
4878 case ST_OMP_PARALLEL_SECTIONS
:
4879 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
4881 case ST_OMP_SECTIONS
:
4882 omp_end_st
= ST_OMP_END_SECTIONS
;
4884 case ST_OMP_ORDERED
:
4885 omp_end_st
= ST_OMP_END_ORDERED
;
4887 case ST_OMP_CRITICAL
:
4888 omp_end_st
= ST_OMP_END_CRITICAL
;
4891 omp_end_st
= ST_OMP_END_MASTER
;
4894 omp_end_st
= ST_OMP_END_SINGLE
;
4897 omp_end_st
= ST_OMP_END_TARGET
;
4899 case ST_OMP_TARGET_DATA
:
4900 omp_end_st
= ST_OMP_END_TARGET_DATA
;
4902 case ST_OMP_TARGET_TEAMS
:
4903 omp_end_st
= ST_OMP_END_TARGET_TEAMS
;
4905 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4906 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4908 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4909 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4911 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4912 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4914 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4915 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4918 omp_end_st
= ST_OMP_END_TASK
;
4920 case ST_OMP_TASKGROUP
:
4921 omp_end_st
= ST_OMP_END_TASKGROUP
;
4924 omp_end_st
= ST_OMP_END_TEAMS
;
4926 case ST_OMP_TEAMS_DISTRIBUTE
:
4927 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4929 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4930 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4932 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4933 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4935 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4936 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4938 case ST_OMP_DISTRIBUTE
:
4939 omp_end_st
= ST_OMP_END_DISTRIBUTE
;
4941 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4942 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4944 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4945 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4947 case ST_OMP_DISTRIBUTE_SIMD
:
4948 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4950 case ST_OMP_WORKSHARE
:
4951 omp_end_st
= ST_OMP_END_WORKSHARE
;
4953 case ST_OMP_PARALLEL_WORKSHARE
:
4954 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
4962 if (workshare_stmts_only
)
4964 /* Inside of !$omp workshare, only
4967 where statements and constructs
4968 forall statements and constructs
4972 are allowed. For !$omp critical these
4973 restrictions apply recursively. */
4976 st
= next_statement ();
4987 accept_statement (st
);
4990 case ST_WHERE_BLOCK
:
4991 parse_where_block ();
4994 case ST_FORALL_BLOCK
:
4995 parse_forall_block ();
4998 case ST_OMP_PARALLEL
:
4999 case ST_OMP_PARALLEL_SECTIONS
:
5000 parse_omp_structured_block (st
, false);
5003 case ST_OMP_PARALLEL_WORKSHARE
:
5004 case ST_OMP_CRITICAL
:
5005 parse_omp_structured_block (st
, true);
5008 case ST_OMP_PARALLEL_DO
:
5009 case ST_OMP_PARALLEL_DO_SIMD
:
5010 st
= parse_omp_do (st
);
5014 st
= parse_omp_oacc_atomic (true);
5025 st
= next_statement ();
5029 st
= parse_executable (ST_NONE
);
5032 else if (st
== ST_OMP_SECTION
5033 && (omp_st
== ST_OMP_SECTIONS
5034 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
5036 np
= new_level (np
);
5040 else if (st
!= omp_end_st
)
5041 unexpected_statement (st
);
5043 while (st
!= omp_end_st
);
5047 case EXEC_OMP_END_NOWAIT
:
5048 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
5050 case EXEC_OMP_CRITICAL
:
5051 if (((cp
->ext
.omp_name
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
5052 || (new_st
.ext
.omp_name
!= NULL
5053 && strcmp (cp
->ext
.omp_name
, new_st
.ext
.omp_name
) != 0))
5054 gfc_error ("Name after !$omp critical and !$omp end critical does "
5056 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
5058 case EXEC_OMP_END_SINGLE
:
5059 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
5060 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
5061 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
5062 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
5070 gfc_clear_new_st ();
5071 gfc_commit_symbols ();
5072 gfc_warning_check ();
5077 /* Accept a series of executable statements. We return the first
5078 statement that doesn't fit to the caller. Any block statements are
5079 passed on to the correct handler, which usually passes the buck
5082 static gfc_statement
5083 parse_executable (gfc_statement st
)
5088 st
= next_statement ();
5092 close_flag
= check_do_closure ();
5097 case ST_END_PROGRAM
:
5100 case ST_END_FUNCTION
:
5105 case ST_END_SUBROUTINE
:
5110 case ST_SELECT_CASE
:
5111 gfc_error ("%s statement at %C cannot terminate a non-block "
5112 "DO loop", gfc_ascii_statement (st
));
5125 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
5126 "first executable statement");
5132 accept_statement (st
);
5133 if (close_flag
== 1)
5134 return ST_IMPLIED_ENDDO
;
5138 parse_block_construct ();
5149 case ST_SELECT_CASE
:
5150 parse_select_block ();
5153 case ST_SELECT_TYPE
:
5154 parse_select_type_block();
5159 if (check_do_closure () == 1)
5160 return ST_IMPLIED_ENDDO
;
5164 parse_critical_block ();
5167 case ST_WHERE_BLOCK
:
5168 parse_where_block ();
5171 case ST_FORALL_BLOCK
:
5172 parse_forall_block ();
5175 case ST_OACC_PARALLEL_LOOP
:
5176 case ST_OACC_KERNELS_LOOP
:
5178 st
= parse_oacc_loop (st
);
5179 if (st
== ST_IMPLIED_ENDDO
)
5183 case ST_OACC_PARALLEL
:
5184 case ST_OACC_KERNELS
:
5186 case ST_OACC_HOST_DATA
:
5187 parse_oacc_structured_block (st
);
5190 case ST_OMP_PARALLEL
:
5191 case ST_OMP_PARALLEL_SECTIONS
:
5192 case ST_OMP_SECTIONS
:
5193 case ST_OMP_ORDERED
:
5194 case ST_OMP_CRITICAL
:
5198 case ST_OMP_TARGET_DATA
:
5199 case ST_OMP_TARGET_TEAMS
:
5202 case ST_OMP_TASKGROUP
:
5203 parse_omp_structured_block (st
, false);
5206 case ST_OMP_WORKSHARE
:
5207 case ST_OMP_PARALLEL_WORKSHARE
:
5208 parse_omp_structured_block (st
, true);
5211 case ST_OMP_DISTRIBUTE
:
5212 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5213 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5214 case ST_OMP_DISTRIBUTE_SIMD
:
5216 case ST_OMP_DO_SIMD
:
5217 case ST_OMP_PARALLEL_DO
:
5218 case ST_OMP_PARALLEL_DO_SIMD
:
5220 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5221 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5222 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5223 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5224 case ST_OMP_TEAMS_DISTRIBUTE
:
5225 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5226 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5227 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5228 st
= parse_omp_do (st
);
5229 if (st
== ST_IMPLIED_ENDDO
)
5233 case ST_OACC_ATOMIC
:
5234 st
= parse_omp_oacc_atomic (false);
5238 st
= parse_omp_oacc_atomic (true);
5245 st
= next_statement ();
5250 /* Fix the symbols for sibling functions. These are incorrectly added to
5251 the child namespace as the parser didn't know about this procedure. */
5254 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
5258 gfc_symbol
*old_sym
;
5260 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
5262 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
5264 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
5265 goto fixup_contained
;
5267 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
5268 && sym
->attr
.generic
&& sym
->attr
.function
)
5269 ||(sym
->attr
.flavor
== FL_DERIVED
5270 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
5271 goto fixup_contained
;
5273 old_sym
= st
->n
.sym
;
5274 if (old_sym
->ns
== ns
5275 && !old_sym
->attr
.contained
5277 /* By 14.6.1.3, host association should be excluded
5278 for the following. */
5279 && !(old_sym
->attr
.external
5280 || (old_sym
->ts
.type
!= BT_UNKNOWN
5281 && !old_sym
->attr
.implicit_type
)
5282 || old_sym
->attr
.flavor
== FL_PARAMETER
5283 || old_sym
->attr
.use_assoc
5284 || old_sym
->attr
.in_common
5285 || old_sym
->attr
.in_equivalence
5286 || old_sym
->attr
.data
5287 || old_sym
->attr
.dummy
5288 || old_sym
->attr
.result
5289 || old_sym
->attr
.dimension
5290 || old_sym
->attr
.allocatable
5291 || old_sym
->attr
.intrinsic
5292 || old_sym
->attr
.generic
5293 || old_sym
->attr
.flavor
== FL_NAMELIST
5294 || old_sym
->attr
.flavor
== FL_LABEL
5295 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
5297 /* Replace it with the symbol from the parent namespace. */
5301 gfc_release_symbol (old_sym
);
5305 /* Do the same for any contained procedures. */
5306 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
5311 parse_contained (int module
)
5313 gfc_namespace
*ns
, *parent_ns
, *tmp
;
5314 gfc_state_data s1
, s2
;
5319 int contains_statements
= 0;
5322 push_state (&s1
, COMP_CONTAINS
, NULL
);
5323 parent_ns
= gfc_current_ns
;
5327 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
5329 gfc_current_ns
->sibling
= parent_ns
->contained
;
5330 parent_ns
->contained
= gfc_current_ns
;
5333 /* Process the next available statement. We come here if we got an error
5334 and rejected the last statement. */
5335 old_loc
= gfc_current_locus
;
5336 st
= next_statement ();
5345 contains_statements
= 1;
5346 accept_statement (st
);
5349 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
5352 /* For internal procedures, create/update the symbol in the
5353 parent namespace. */
5357 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
5358 gfc_error ("Contained procedure %qs at %C is already "
5359 "ambiguous", gfc_new_block
->name
);
5362 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
5364 &gfc_new_block
->declared_at
))
5366 if (st
== ST_FUNCTION
)
5367 gfc_add_function (&sym
->attr
, sym
->name
,
5368 &gfc_new_block
->declared_at
);
5370 gfc_add_subroutine (&sym
->attr
, sym
->name
,
5371 &gfc_new_block
->declared_at
);
5375 gfc_commit_symbols ();
5378 sym
= gfc_new_block
;
5380 /* Mark this as a contained function, so it isn't replaced
5381 by other module functions. */
5382 sym
->attr
.contained
= 1;
5384 /* Set implicit_pure so that it can be reset if any of the
5385 tests for purity fail. This is used for some optimisation
5386 during translation. */
5387 if (!sym
->attr
.pure
)
5388 sym
->attr
.implicit_pure
= 1;
5390 parse_progunit (ST_NONE
);
5392 /* Fix up any sibling functions that refer to this one. */
5393 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
5394 /* Or refer to any of its alternate entry points. */
5395 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
5396 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
5398 gfc_current_ns
->code
= s2
.head
;
5399 gfc_current_ns
= parent_ns
;
5404 /* These statements are associated with the end of the host unit. */
5405 case ST_END_FUNCTION
:
5407 case ST_END_SUBMODULE
:
5408 case ST_END_PROGRAM
:
5409 case ST_END_SUBROUTINE
:
5410 accept_statement (st
);
5411 gfc_current_ns
->code
= s1
.head
;
5415 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
5416 gfc_ascii_statement (st
));
5417 reject_statement ();
5423 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
5424 && st
!= ST_END_MODULE
&& st
!= ST_END_SUBMODULE
5425 && st
!= ST_END_PROGRAM
);
5427 /* The first namespace in the list is guaranteed to not have
5428 anything (worthwhile) in it. */
5429 tmp
= gfc_current_ns
;
5430 gfc_current_ns
= parent_ns
;
5431 if (seen_error
&& tmp
->refs
> 1)
5432 gfc_free_namespace (tmp
);
5434 ns
= gfc_current_ns
->contained
;
5435 gfc_current_ns
->contained
= ns
->sibling
;
5436 gfc_free_namespace (ns
);
5439 if (!contains_statements
)
5440 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
5441 "FUNCTION or SUBROUTINE statement at %L", &old_loc
);
5445 /* The result variable in a MODULE PROCEDURE needs to be created and
5446 its characteristics copied from the interface since it is neither
5447 declared in the procedure declaration nor in the specification
5451 get_modproc_result (void)
5454 if (gfc_state_stack
->previous
5455 && gfc_state_stack
->previous
->state
== COMP_CONTAINS
5456 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
5458 proc
= gfc_current_ns
->proc_name
? gfc_current_ns
->proc_name
: NULL
;
5460 && proc
->attr
.function
5461 && proc
->ts
.interface
5462 && proc
->ts
.interface
->result
5463 && proc
->ts
.interface
->result
!= proc
->ts
.interface
)
5465 gfc_copy_dummy_sym (&proc
->result
, proc
->ts
.interface
->result
, 1);
5466 gfc_set_sym_referenced (proc
->result
);
5467 proc
->result
->attr
.if_source
= IFSRC_DECL
;
5468 gfc_commit_symbol (proc
->result
);
5474 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
5477 parse_progunit (gfc_statement st
)
5483 && gfc_new_block
->abr_modproc_decl
5484 && gfc_new_block
->attr
.function
)
5485 get_modproc_result ();
5487 st
= parse_spec (st
);
5494 /* This is not allowed within BLOCK! */
5495 if (gfc_current_state () != COMP_BLOCK
)
5500 accept_statement (st
);
5507 if (gfc_current_state () == COMP_FUNCTION
)
5508 gfc_check_function_type (gfc_current_ns
);
5513 st
= parse_executable (st
);
5521 /* This is not allowed within BLOCK! */
5522 if (gfc_current_state () != COMP_BLOCK
)
5527 accept_statement (st
);
5534 unexpected_statement (st
);
5535 reject_statement ();
5536 st
= next_statement ();
5542 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
5543 if (p
->state
== COMP_CONTAINS
)
5546 if (gfc_find_state (COMP_MODULE
) == true
5547 || gfc_find_state (COMP_SUBMODULE
) == true)
5552 gfc_error ("CONTAINS statement at %C is already in a contained "
5554 reject_statement ();
5555 st
= next_statement ();
5559 parse_contained (0);
5562 gfc_current_ns
->code
= gfc_state_stack
->head
;
5566 /* Come here to complain about a global symbol already in use as
5570 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
5575 where
= &gfc_current_locus
;
5585 case GSYM_SUBROUTINE
:
5586 name
= "SUBROUTINE";
5591 case GSYM_BLOCK_DATA
:
5592 name
= "BLOCK DATA";
5598 gfc_internal_error ("gfc_global_used(): Bad type");
5602 if (sym
->binding_label
)
5603 gfc_error ("Global binding name %qs at %L is already being used as a %s "
5604 "at %L", sym
->binding_label
, where
, name
, &sym
->where
);
5606 gfc_error ("Global name %qs at %L is already being used as a %s at %L",
5607 sym
->name
, where
, name
, &sym
->where
);
5611 /* Parse a block data program unit. */
5614 parse_block_data (void)
5617 static locus blank_locus
;
5618 static int blank_block
=0;
5621 gfc_current_ns
->proc_name
= gfc_new_block
;
5622 gfc_current_ns
->is_block_data
= 1;
5624 if (gfc_new_block
== NULL
)
5627 gfc_error ("Blank BLOCK DATA at %C conflicts with "
5628 "prior BLOCK DATA at %L", &blank_locus
);
5632 blank_locus
= gfc_current_locus
;
5637 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5639 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
5640 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5643 s
->type
= GSYM_BLOCK_DATA
;
5644 s
->where
= gfc_new_block
->declared_at
;
5649 st
= parse_spec (ST_NONE
);
5651 while (st
!= ST_END_BLOCK_DATA
)
5653 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
5654 gfc_ascii_statement (st
));
5655 reject_statement ();
5656 st
= next_statement ();
5661 /* Following the association of the ancestor (sub)module symbols, they
5662 must be set host rather than use associated and all must be public.
5663 They are flagged up by 'used_in_submodule' so that they can be set
5664 DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
5665 linker chokes on multiple symbol definitions. */
5668 set_syms_host_assoc (gfc_symbol
*sym
)
5675 if (sym
->attr
.module_procedure
)
5676 sym
->attr
.external
= 0;
5678 /* sym->attr.access = ACCESS_PUBLIC; */
5680 sym
->attr
.use_assoc
= 0;
5681 sym
->attr
.host_assoc
= 1;
5682 sym
->attr
.used_in_submodule
=1;
5684 if (sym
->attr
.flavor
== FL_DERIVED
)
5686 for (c
= sym
->components
; c
; c
= c
->next
)
5687 c
->attr
.access
= ACCESS_PUBLIC
;
5691 /* Parse a module subprogram. */
5700 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5701 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
5702 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5705 s
->type
= GSYM_MODULE
;
5706 s
->where
= gfc_new_block
->declared_at
;
5710 /* Something is nulling the module_list after this point. This is good
5711 since it allows us to 'USE' the parent modules that the submodule
5712 inherits and to set (most) of the symbols as host associated. */
5713 if (gfc_current_state () == COMP_SUBMODULE
)
5716 gfc_traverse_ns (gfc_current_ns
, set_syms_host_assoc
);
5719 st
= parse_spec (ST_NONE
);
5729 parse_contained (1);
5733 case ST_END_SUBMODULE
:
5734 accept_statement (st
);
5738 gfc_error ("Unexpected %s statement in MODULE at %C",
5739 gfc_ascii_statement (st
));
5742 reject_statement ();
5743 st
= next_statement ();
5747 /* Make sure not to free the namespace twice on error. */
5749 s
->ns
= gfc_current_ns
;
5753 /* Add a procedure name to the global symbol table. */
5756 add_global_procedure (bool sub
)
5760 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5761 name is a global identifier. */
5762 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5764 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5767 || (s
->type
!= GSYM_UNKNOWN
5768 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5770 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5771 /* Silence follow-up errors. */
5772 gfc_new_block
->binding_label
= NULL
;
5776 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5777 s
->sym_name
= gfc_new_block
->name
;
5778 s
->where
= gfc_new_block
->declared_at
;
5780 s
->ns
= gfc_current_ns
;
5784 /* Don't add the symbol multiple times. */
5785 if (gfc_new_block
->binding_label
5786 && (!gfc_notification_std (GFC_STD_F2008
)
5787 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
5789 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
);
5792 || (s
->type
!= GSYM_UNKNOWN
5793 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5795 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5796 /* Silence follow-up errors. */
5797 gfc_new_block
->binding_label
= NULL
;
5801 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5802 s
->sym_name
= gfc_new_block
->name
;
5803 s
->binding_label
= gfc_new_block
->binding_label
;
5804 s
->where
= gfc_new_block
->declared_at
;
5806 s
->ns
= gfc_current_ns
;
5812 /* Add a program to the global symbol table. */
5815 add_global_program (void)
5819 if (gfc_new_block
== NULL
)
5821 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5823 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
5824 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5827 s
->type
= GSYM_PROGRAM
;
5828 s
->where
= gfc_new_block
->declared_at
;
5830 s
->ns
= gfc_current_ns
;
5835 /* Resolve all the program units. */
5837 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
5839 gfc_free_dt_list ();
5840 gfc_current_ns
= gfc_global_ns_list
;
5841 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5843 if (gfc_current_ns
->proc_name
5844 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5845 continue; /* Already resolved. */
5847 if (gfc_current_ns
->proc_name
)
5848 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5849 gfc_resolve (gfc_current_ns
);
5850 gfc_current_ns
->derived_types
= gfc_derived_types
;
5851 gfc_derived_types
= NULL
;
5857 clean_up_modules (gfc_gsymbol
*gsym
)
5862 clean_up_modules (gsym
->left
);
5863 clean_up_modules (gsym
->right
);
5865 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
5868 gfc_current_ns
= gsym
->ns
;
5869 gfc_derived_types
= gfc_current_ns
->derived_types
;
5876 /* Translate all the program units. This could be in a different order
5877 to resolution if there are forward references in the file. */
5879 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
5883 gfc_current_ns
= gfc_global_ns_list
;
5884 gfc_get_errors (NULL
, &errors
);
5886 /* We first translate all modules to make sure that later parts
5887 of the program can use the decl. Then we translate the nonmodules. */
5889 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5891 if (!gfc_current_ns
->proc_name
5892 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5895 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5896 gfc_derived_types
= gfc_current_ns
->derived_types
;
5897 gfc_generate_module_code (gfc_current_ns
);
5898 gfc_current_ns
->translated
= 1;
5901 gfc_current_ns
= gfc_global_ns_list
;
5902 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5904 if (gfc_current_ns
->proc_name
5905 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5908 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5909 gfc_derived_types
= gfc_current_ns
->derived_types
;
5910 gfc_generate_code (gfc_current_ns
);
5911 gfc_current_ns
->translated
= 1;
5914 /* Clean up all the namespaces after translation. */
5915 gfc_current_ns
= gfc_global_ns_list
;
5916 for (;gfc_current_ns
;)
5920 if (gfc_current_ns
->proc_name
5921 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5923 gfc_current_ns
= gfc_current_ns
->sibling
;
5927 ns
= gfc_current_ns
->sibling
;
5928 gfc_derived_types
= gfc_current_ns
->derived_types
;
5930 gfc_current_ns
= ns
;
5933 clean_up_modules (gfc_gsym_root
);
5937 /* Top level parser. */
5940 gfc_parse_file (void)
5942 int seen_program
, errors_before
, errors
;
5943 gfc_state_data top
, s
;
5946 gfc_namespace
*next
;
5948 gfc_start_source_files ();
5950 top
.state
= COMP_NONE
;
5952 top
.previous
= NULL
;
5953 top
.head
= top
.tail
= NULL
;
5954 top
.do_variable
= NULL
;
5956 gfc_state_stack
= &top
;
5958 gfc_clear_new_st ();
5960 gfc_statement_label
= NULL
;
5962 if (setjmp (eof_buf
))
5963 return false; /* Come here on unexpected EOF */
5965 /* Prepare the global namespace that will contain the
5967 gfc_global_ns_list
= next
= NULL
;
5972 /* Exit early for empty files. */
5976 in_specification_block
= true;
5979 st
= next_statement ();
5988 goto duplicate_main
;
5990 prog_locus
= gfc_current_locus
;
5992 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
5993 main_program_symbol(gfc_current_ns
, gfc_new_block
->name
);
5994 accept_statement (st
);
5995 add_global_program ();
5996 parse_progunit (ST_NONE
);
6001 add_global_procedure (true);
6002 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
6003 accept_statement (st
);
6004 parse_progunit (ST_NONE
);
6009 add_global_procedure (false);
6010 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
6011 accept_statement (st
);
6012 parse_progunit (ST_NONE
);
6017 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
6018 accept_statement (st
);
6019 parse_block_data ();
6023 push_state (&s
, COMP_MODULE
, gfc_new_block
);
6024 accept_statement (st
);
6026 gfc_get_errors (NULL
, &errors_before
);
6031 push_state (&s
, COMP_SUBMODULE
, gfc_new_block
);
6032 accept_statement (st
);
6034 gfc_get_errors (NULL
, &errors_before
);
6038 /* Anything else starts a nameless main program block. */
6041 goto duplicate_main
;
6043 prog_locus
= gfc_current_locus
;
6045 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
6046 main_program_symbol (gfc_current_ns
, "MAIN__");
6047 parse_progunit (st
);
6052 /* Handle the non-program units. */
6053 gfc_current_ns
->code
= s
.head
;
6055 gfc_resolve (gfc_current_ns
);
6057 /* Dump the parse tree if requested. */
6058 if (flag_dump_fortran_original
)
6059 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6061 gfc_get_errors (NULL
, &errors
);
6062 if (s
.state
== COMP_MODULE
|| s
.state
== COMP_SUBMODULE
)
6064 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
6065 gfc_current_ns
->derived_types
= gfc_derived_types
;
6066 gfc_derived_types
= NULL
;
6072 gfc_generate_code (gfc_current_ns
);
6080 /* The main program and non-contained procedures are put
6081 in the global namespace list, so that they can be processed
6082 later and all their interfaces resolved. */
6083 gfc_current_ns
->code
= s
.head
;
6086 for (; next
->sibling
; next
= next
->sibling
)
6088 next
->sibling
= gfc_current_ns
;
6091 gfc_global_ns_list
= gfc_current_ns
;
6093 next
= gfc_current_ns
;
6100 /* Do the resolution. */
6101 resolve_all_program_units (gfc_global_ns_list
);
6103 /* Do the parse tree dump. */
6105 = flag_dump_fortran_original
? gfc_global_ns_list
: NULL
;
6107 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6108 if (!gfc_current_ns
->proc_name
6109 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6111 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6112 fputs ("------------------------------------------\n\n", stdout
);
6115 /* Do the translation. */
6116 translate_all_program_units (gfc_global_ns_list
);
6118 gfc_end_source_files ();
6122 /* If we see a duplicate main program, shut down. If the second
6123 instance is an implied main program, i.e. data decls or executable
6124 statements, we're in for lots of errors. */
6125 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
6126 reject_statement ();
6131 /* Return true if this state data represents an OpenACC region. */
6133 is_oacc (gfc_state_data
*sd
)
6135 switch (sd
->construct
->op
)
6137 case EXEC_OACC_PARALLEL_LOOP
:
6138 case EXEC_OACC_PARALLEL
:
6139 case EXEC_OACC_KERNELS_LOOP
:
6140 case EXEC_OACC_KERNELS
:
6141 case EXEC_OACC_DATA
:
6142 case EXEC_OACC_HOST_DATA
:
6143 case EXEC_OACC_LOOP
:
6144 case EXEC_OACC_UPDATE
:
6145 case EXEC_OACC_WAIT
:
6146 case EXEC_OACC_CACHE
:
6147 case EXEC_OACC_ENTER_DATA
:
6148 case EXEC_OACC_EXIT_DATA
:
6149 case EXEC_OACC_ATOMIC
:
6150 case EXEC_OACC_ROUTINE
: