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
)
1075 gfc_warning_now (0, "Ignoring statement label in empty statement "
1076 "at %L", &label_locus
);
1077 gfc_free_st_label (gfc_statement_label
);
1078 gfc_statement_label
= NULL
;
1085 /* Comments have already been skipped by the time we get here,
1086 except for GCC attributes and OpenMP/OpenACC directives. */
1088 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
1089 c
= gfc_peek_ascii_char ();
1095 c
= gfc_next_ascii_char ();
1096 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
1097 gcc_assert (c
== "gcc$"[i
]);
1099 gfc_gobble_whitespace ();
1100 return decode_gcc_attribute ();
1105 /* Since both OpenMP and OpenACC directives starts with
1106 !$ character sequence, we must check all flags combinations */
1107 if ((flag_openmp
|| flag_openmp_simd
)
1110 verify_token_free ("$omp", 4, last_was_use_stmt
);
1111 return decode_omp_directive ();
1113 else if ((flag_openmp
|| flag_openmp_simd
)
1116 gfc_next_ascii_char (); /* Eat up dollar character */
1117 c
= gfc_peek_ascii_char ();
1121 verify_token_free ("omp", 3, last_was_use_stmt
);
1122 return decode_omp_directive ();
1126 verify_token_free ("acc", 3, last_was_use_stmt
);
1127 return decode_oacc_directive ();
1130 else if (flag_openacc
)
1132 verify_token_free ("$acc", 4, last_was_use_stmt
);
1133 return decode_oacc_directive ();
1139 if (at_bol
&& c
== ';')
1141 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1142 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1144 gfc_next_ascii_char (); /* Eat up the semicolon. */
1148 return decode_statement ();
1151 /* Assert next length characters to be equal to token in fixed form. */
1154 verify_token_fixed (const char *token
, int length
, bool last_was_use_stmt
)
1157 char c
= gfc_next_char_literal (NONSTRING
);
1159 for (i
= 0; i
< length
; i
++, c
= gfc_next_char_literal (NONSTRING
))
1160 gcc_assert ((char) gfc_wide_tolower (c
) == token
[i
]);
1162 if (c
!= ' ' && c
!= '0')
1164 gfc_buffer_error (false);
1165 gfc_error ("Bad continuation line at %C");
1168 if (last_was_use_stmt
)
1174 /* Get the next statement in fixed-form source. */
1176 static gfc_statement
1179 int label
, digit_flag
, i
;
1184 return decode_statement ();
1186 /* Skip past the current label field, parsing a statement label if
1187 one is there. This is a weird number parser, since the number is
1188 contained within five columns and can have any kind of embedded
1189 spaces. We also check for characters that make the rest of the
1195 for (i
= 0; i
< 5; i
++)
1197 c
= gfc_next_char_literal (NONSTRING
);
1214 label
= label
* 10 + ((unsigned char) c
- '0');
1215 label_locus
= gfc_current_locus
;
1219 /* Comments have already been skipped by the time we get
1220 here, except for GCC attributes and OpenMP directives. */
1223 c
= gfc_next_char_literal (NONSTRING
);
1225 if (TOLOWER (c
) == 'g')
1227 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
1228 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
1230 return decode_gcc_attribute ();
1234 if ((flag_openmp
|| flag_openmp_simd
)
1237 if (!verify_token_fixed ("omp", 3, last_was_use_stmt
))
1239 return decode_omp_directive ();
1241 else if ((flag_openmp
|| flag_openmp_simd
)
1244 c
= gfc_next_char_literal(NONSTRING
);
1245 if (c
== 'o' || c
== 'O')
1247 if (!verify_token_fixed ("mp", 2, last_was_use_stmt
))
1249 return decode_omp_directive ();
1251 else if (c
== 'a' || c
== 'A')
1253 if (!verify_token_fixed ("cc", 2, last_was_use_stmt
))
1255 return decode_oacc_directive ();
1258 else if (flag_openacc
)
1260 if (!verify_token_fixed ("acc", 3, last_was_use_stmt
))
1262 return decode_oacc_directive ();
1267 /* Comments have already been skipped by the time we get
1268 here so don't bother checking for them. */
1271 gfc_buffer_error (false);
1272 gfc_error ("Non-numeric character in statement label at %C");
1280 gfc_warning_now (0, "Zero is not a valid statement label at %C");
1283 /* We've found a valid statement label. */
1284 gfc_statement_label
= gfc_get_st_label (label
);
1288 /* Since this line starts a statement, it cannot be a continuation
1289 of a previous statement. If we see something here besides a
1290 space or zero, it must be a bad continuation line. */
1292 c
= gfc_next_char_literal (NONSTRING
);
1296 if (c
!= ' ' && c
!= '0')
1298 gfc_buffer_error (false);
1299 gfc_error ("Bad continuation line at %C");
1303 /* Now that we've taken care of the statement label columns, we have
1304 to make sure that the first nonblank character is not a '!'. If
1305 it is, the rest of the line is a comment. */
1309 loc
= gfc_current_locus
;
1310 c
= gfc_next_char_literal (NONSTRING
);
1312 while (gfc_is_whitespace (c
));
1316 gfc_current_locus
= loc
;
1321 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1322 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1323 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1328 if (gfc_match_eos () == MATCH_YES
)
1331 /* At this point, we've got a nonblank statement to parse. */
1332 return decode_statement ();
1336 gfc_warning_now (0, "Ignoring statement label in empty statement at %L",
1339 gfc_current_locus
.lb
->truncated
= 0;
1340 gfc_advance_line ();
1345 /* Return the next non-ST_NONE statement to the caller. We also worry
1346 about including files and the ends of include files at this stage. */
1348 static gfc_statement
1349 next_statement (void)
1354 gfc_enforce_clean_symbol_state ();
1356 gfc_new_block
= NULL
;
1358 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
1359 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1360 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
1363 gfc_statement_label
= NULL
;
1364 gfc_buffer_error (true);
1367 gfc_advance_line ();
1369 gfc_skip_comments ();
1377 if (gfc_define_undef_line ())
1380 old_locus
= gfc_current_locus
;
1382 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1388 gfc_buffer_error (false);
1390 if (st
== ST_GET_FCN_CHARACTERISTICS
)
1392 if (gfc_statement_label
!= NULL
)
1394 gfc_free_st_label (gfc_statement_label
);
1395 gfc_statement_label
= NULL
;
1397 gfc_current_locus
= old_locus
;
1401 check_statement_label (st
);
1407 /****************************** Parser ***********************************/
1409 /* The parser subroutines are of type 'try' that fail if the file ends
1412 /* Macros that expand to case-labels for various classes of
1413 statements. Start with executable statements that directly do
1416 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1417 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1418 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1419 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1420 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1421 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1422 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1423 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1424 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1425 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
1426 case ST_OMP_TARGET_UPDATE: case ST_ERROR_STOP: case ST_SYNC_ALL: \
1427 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1428 case ST_EVENT_POST: case ST_EVENT_WAIT: \
1429 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1430 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1432 /* Statements that mark other executable statements. */
1434 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1435 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1436 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1437 case ST_OMP_PARALLEL: \
1438 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1439 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
1440 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1441 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1442 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1443 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1444 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1445 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1446 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1447 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1448 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1449 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1450 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1451 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1452 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1453 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1454 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: \
1456 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1457 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
1458 case ST_OACC_KERNELS_LOOP: case ST_OACC_ATOMIC
1460 /* Declaration statements */
1462 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1463 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1464 case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE: case ST_OACC_ROUTINE: \
1465 case ST_OACC_DECLARE
1467 /* OpenMP declaration statements. */
1469 #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
1470 case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION
1472 /* Block end statements. Errors associated with interchanging these
1473 are detected in gfc_match_end(). */
1475 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1476 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1477 case ST_END_BLOCK: case ST_END_ASSOCIATE
1480 /* Push a new state onto the stack. */
1483 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1485 p
->state
= new_state
;
1486 p
->previous
= gfc_state_stack
;
1488 p
->head
= p
->tail
= NULL
;
1489 p
->do_variable
= NULL
;
1490 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1491 p
->ext
.oacc_declare_clauses
= NULL
;
1493 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1494 construct statement was accepted right before pushing the state. Thus,
1495 the construct's gfc_code is available as tail of the parent state. */
1496 gcc_assert (gfc_state_stack
);
1497 p
->construct
= gfc_state_stack
->tail
;
1499 gfc_state_stack
= p
;
1503 /* Pop the current state. */
1507 gfc_state_stack
= gfc_state_stack
->previous
;
1511 /* Try to find the given state in the state stack. */
1514 gfc_find_state (gfc_compile_state state
)
1518 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1519 if (p
->state
== state
)
1522 return (p
== NULL
) ? false : true;
1526 /* Starts a new level in the statement list. */
1529 new_level (gfc_code
*q
)
1533 p
= q
->block
= gfc_get_code (EXEC_NOP
);
1535 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1541 /* Add the current new_st code structure and adds it to the current
1542 program unit. As a side-effect, it zeroes the new_st. */
1545 add_statement (void)
1549 p
= XCNEW (gfc_code
);
1552 p
->loc
= gfc_current_locus
;
1554 if (gfc_state_stack
->head
== NULL
)
1555 gfc_state_stack
->head
= p
;
1557 gfc_state_stack
->tail
->next
= p
;
1559 while (p
->next
!= NULL
)
1562 gfc_state_stack
->tail
= p
;
1564 gfc_clear_new_st ();
1570 /* Frees everything associated with the current statement. */
1573 undo_new_statement (void)
1575 gfc_free_statements (new_st
.block
);
1576 gfc_free_statements (new_st
.next
);
1577 gfc_free_statement (&new_st
);
1578 gfc_clear_new_st ();
1582 /* If the current statement has a statement label, make sure that it
1583 is allowed to, or should have one. */
1586 check_statement_label (gfc_statement st
)
1590 if (gfc_statement_label
== NULL
)
1592 if (st
== ST_FORMAT
)
1593 gfc_error ("FORMAT statement at %L does not have a statement label",
1600 case ST_END_PROGRAM
:
1601 case ST_END_FUNCTION
:
1602 case ST_END_SUBROUTINE
:
1606 case ST_END_CRITICAL
:
1608 case ST_END_ASSOCIATE
:
1611 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
1612 type
= ST_LABEL_DO_TARGET
;
1614 type
= ST_LABEL_TARGET
;
1618 type
= ST_LABEL_FORMAT
;
1621 /* Statement labels are not restricted from appearing on a
1622 particular line. However, there are plenty of situations
1623 where the resulting label can't be referenced. */
1626 type
= ST_LABEL_BAD_TARGET
;
1630 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1632 new_st
.here
= gfc_statement_label
;
1636 /* Figures out what the enclosing program unit is. This will be a
1637 function, subroutine, program, block data or module. */
1640 gfc_enclosing_unit (gfc_compile_state
* result
)
1644 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1645 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1646 || p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
1647 || p
->state
== COMP_BLOCK_DATA
|| p
->state
== COMP_PROGRAM
)
1656 *result
= COMP_PROGRAM
;
1661 /* Translate a statement enum to a string. */
1664 gfc_ascii_statement (gfc_statement st
)
1670 case ST_ARITHMETIC_IF
:
1671 p
= _("arithmetic IF");
1680 p
= _("attribute declaration");
1716 p
= _("data declaration");
1730 case ST_STRUCTURE_DECL
:
1733 case ST_DERIVED_DECL
:
1734 p
= _("derived type declaration");
1754 case ST_END_ASSOCIATE
:
1755 p
= "END ASSOCIATE";
1760 case ST_END_BLOCK_DATA
:
1761 p
= "END BLOCK DATA";
1763 case ST_END_CRITICAL
:
1775 case ST_END_FUNCTION
:
1781 case ST_END_INTERFACE
:
1782 p
= "END INTERFACE";
1787 case ST_END_SUBMODULE
:
1788 p
= "END SUBMODULE";
1790 case ST_END_PROGRAM
:
1796 case ST_END_SUBROUTINE
:
1797 p
= "END SUBROUTINE";
1802 case ST_END_STRUCTURE
:
1803 p
= "END STRUCTURE";
1817 case ST_EQUIVALENCE
:
1829 case ST_FORALL_BLOCK
: /* Fall through */
1851 case ST_IMPLICIT_NONE
:
1852 p
= "IMPLICIT NONE";
1854 case ST_IMPLIED_ENDDO
:
1855 p
= _("implied END DO");
1887 case ST_MODULE_PROC
:
1888 p
= "MODULE PROCEDURE";
1920 case ST_SYNC_IMAGES
:
1923 case ST_SYNC_MEMORY
:
1938 case ST_WHERE_BLOCK
: /* Fall through */
1949 p
= _("assignment");
1951 case ST_POINTER_ASSIGNMENT
:
1952 p
= _("pointer assignment");
1954 case ST_SELECT_CASE
:
1957 case ST_SELECT_TYPE
:
1972 case ST_STATEMENT_FUNCTION
:
1973 p
= "STATEMENT FUNCTION";
1975 case ST_LABEL_ASSIGNMENT
:
1976 p
= "LABEL ASSIGNMENT";
1979 p
= "ENUM DEFINITION";
1982 p
= "ENUMERATOR DEFINITION";
1987 case ST_OACC_PARALLEL_LOOP
:
1988 p
= "!$ACC PARALLEL LOOP";
1990 case ST_OACC_END_PARALLEL_LOOP
:
1991 p
= "!$ACC END PARALLEL LOOP";
1993 case ST_OACC_PARALLEL
:
1994 p
= "!$ACC PARALLEL";
1996 case ST_OACC_END_PARALLEL
:
1997 p
= "!$ACC END PARALLEL";
1999 case ST_OACC_KERNELS
:
2000 p
= "!$ACC KERNELS";
2002 case ST_OACC_END_KERNELS
:
2003 p
= "!$ACC END KERNELS";
2005 case ST_OACC_KERNELS_LOOP
:
2006 p
= "!$ACC KERNELS LOOP";
2008 case ST_OACC_END_KERNELS_LOOP
:
2009 p
= "!$ACC END KERNELS LOOP";
2014 case ST_OACC_END_DATA
:
2015 p
= "!$ACC END DATA";
2017 case ST_OACC_HOST_DATA
:
2018 p
= "!$ACC HOST_DATA";
2020 case ST_OACC_END_HOST_DATA
:
2021 p
= "!$ACC END HOST_DATA";
2026 case ST_OACC_END_LOOP
:
2027 p
= "!$ACC END LOOP";
2029 case ST_OACC_DECLARE
:
2030 p
= "!$ACC DECLARE";
2032 case ST_OACC_UPDATE
:
2041 case ST_OACC_ENTER_DATA
:
2042 p
= "!$ACC ENTER DATA";
2044 case ST_OACC_EXIT_DATA
:
2045 p
= "!$ACC EXIT DATA";
2047 case ST_OACC_ROUTINE
:
2048 p
= "!$ACC ROUTINE";
2050 case ST_OACC_ATOMIC
:
2053 case ST_OACC_END_ATOMIC
:
2054 p
= "!ACC END ATOMIC";
2059 case ST_OMP_BARRIER
:
2060 p
= "!$OMP BARRIER";
2065 case ST_OMP_CANCELLATION_POINT
:
2066 p
= "!$OMP CANCELLATION POINT";
2068 case ST_OMP_CRITICAL
:
2069 p
= "!$OMP CRITICAL";
2071 case ST_OMP_DECLARE_REDUCTION
:
2072 p
= "!$OMP DECLARE REDUCTION";
2074 case ST_OMP_DECLARE_SIMD
:
2075 p
= "!$OMP DECLARE SIMD";
2077 case ST_OMP_DECLARE_TARGET
:
2078 p
= "!$OMP DECLARE TARGET";
2080 case ST_OMP_DISTRIBUTE
:
2081 p
= "!$OMP DISTRIBUTE";
2083 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
2084 p
= "!$OMP DISTRIBUTE PARALLEL DO";
2086 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2087 p
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
2089 case ST_OMP_DISTRIBUTE_SIMD
:
2090 p
= "!$OMP DISTRIBUTE SIMD";
2095 case ST_OMP_DO_SIMD
:
2096 p
= "!$OMP DO SIMD";
2098 case ST_OMP_END_ATOMIC
:
2099 p
= "!$OMP END ATOMIC";
2101 case ST_OMP_END_CRITICAL
:
2102 p
= "!$OMP END CRITICAL";
2104 case ST_OMP_END_DISTRIBUTE
:
2105 p
= "!$OMP END DISTRIBUTE";
2107 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO
:
2108 p
= "!$OMP END DISTRIBUTE PARALLEL DO";
2110 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
:
2111 p
= "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
2113 case ST_OMP_END_DISTRIBUTE_SIMD
:
2114 p
= "!$OMP END DISTRIBUTE SIMD";
2119 case ST_OMP_END_DO_SIMD
:
2120 p
= "!$OMP END DO SIMD";
2122 case ST_OMP_END_SIMD
:
2123 p
= "!$OMP END SIMD";
2125 case ST_OMP_END_MASTER
:
2126 p
= "!$OMP END MASTER";
2128 case ST_OMP_END_ORDERED
:
2129 p
= "!$OMP END ORDERED";
2131 case ST_OMP_END_PARALLEL
:
2132 p
= "!$OMP END PARALLEL";
2134 case ST_OMP_END_PARALLEL_DO
:
2135 p
= "!$OMP END PARALLEL DO";
2137 case ST_OMP_END_PARALLEL_DO_SIMD
:
2138 p
= "!$OMP END PARALLEL DO SIMD";
2140 case ST_OMP_END_PARALLEL_SECTIONS
:
2141 p
= "!$OMP END PARALLEL SECTIONS";
2143 case ST_OMP_END_PARALLEL_WORKSHARE
:
2144 p
= "!$OMP END PARALLEL WORKSHARE";
2146 case ST_OMP_END_SECTIONS
:
2147 p
= "!$OMP END SECTIONS";
2149 case ST_OMP_END_SINGLE
:
2150 p
= "!$OMP END SINGLE";
2152 case ST_OMP_END_TASK
:
2153 p
= "!$OMP END TASK";
2155 case ST_OMP_END_TARGET
:
2156 p
= "!$OMP END TARGET";
2158 case ST_OMP_END_TARGET_DATA
:
2159 p
= "!$OMP END TARGET DATA";
2161 case ST_OMP_END_TARGET_TEAMS
:
2162 p
= "!$OMP END TARGET TEAMS";
2164 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
:
2165 p
= "!$OMP END TARGET TEAMS DISTRIBUTE";
2167 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2168 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2170 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2171 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2173 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2174 p
= "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2176 case ST_OMP_END_TASKGROUP
:
2177 p
= "!$OMP END TASKGROUP";
2179 case ST_OMP_END_TEAMS
:
2180 p
= "!$OMP END TEAMS";
2182 case ST_OMP_END_TEAMS_DISTRIBUTE
:
2183 p
= "!$OMP END TEAMS DISTRIBUTE";
2185 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2186 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2188 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2189 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2191 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
:
2192 p
= "!$OMP END TEAMS DISTRIBUTE SIMD";
2194 case ST_OMP_END_WORKSHARE
:
2195 p
= "!$OMP END WORKSHARE";
2203 case ST_OMP_ORDERED
:
2204 p
= "!$OMP ORDERED";
2206 case ST_OMP_PARALLEL
:
2207 p
= "!$OMP PARALLEL";
2209 case ST_OMP_PARALLEL_DO
:
2210 p
= "!$OMP PARALLEL DO";
2212 case ST_OMP_PARALLEL_DO_SIMD
:
2213 p
= "!$OMP PARALLEL DO SIMD";
2215 case ST_OMP_PARALLEL_SECTIONS
:
2216 p
= "!$OMP PARALLEL SECTIONS";
2218 case ST_OMP_PARALLEL_WORKSHARE
:
2219 p
= "!$OMP PARALLEL WORKSHARE";
2221 case ST_OMP_SECTIONS
:
2222 p
= "!$OMP SECTIONS";
2224 case ST_OMP_SECTION
:
2225 p
= "!$OMP SECTION";
2236 case ST_OMP_TARGET_DATA
:
2237 p
= "!$OMP TARGET DATA";
2239 case ST_OMP_TARGET_TEAMS
:
2240 p
= "!$OMP TARGET TEAMS";
2242 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
2243 p
= "!$OMP TARGET TEAMS DISTRIBUTE";
2245 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2246 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2248 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2249 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2251 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2252 p
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2254 case ST_OMP_TARGET_UPDATE
:
2255 p
= "!$OMP TARGET UPDATE";
2260 case ST_OMP_TASKGROUP
:
2261 p
= "!$OMP TASKGROUP";
2263 case ST_OMP_TASKWAIT
:
2264 p
= "!$OMP TASKWAIT";
2266 case ST_OMP_TASKYIELD
:
2267 p
= "!$OMP TASKYIELD";
2272 case ST_OMP_TEAMS_DISTRIBUTE
:
2273 p
= "!$OMP TEAMS DISTRIBUTE";
2275 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2276 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2278 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2279 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2281 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
2282 p
= "!$OMP TEAMS DISTRIBUTE SIMD";
2284 case ST_OMP_THREADPRIVATE
:
2285 p
= "!$OMP THREADPRIVATE";
2287 case ST_OMP_WORKSHARE
:
2288 p
= "!$OMP WORKSHARE";
2291 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2298 /* Create a symbol for the main program and assign it to ns->proc_name. */
2301 main_program_symbol (gfc_namespace
*ns
, const char *name
)
2303 gfc_symbol
*main_program
;
2304 symbol_attribute attr
;
2306 gfc_get_symbol (name
, ns
, &main_program
);
2307 gfc_clear_attr (&attr
);
2308 attr
.flavor
= FL_PROGRAM
;
2309 attr
.proc
= PROC_UNKNOWN
;
2310 attr
.subroutine
= 1;
2311 attr
.access
= ACCESS_PUBLIC
;
2312 attr
.is_main_program
= 1;
2313 main_program
->attr
= attr
;
2314 main_program
->declared_at
= gfc_current_locus
;
2315 ns
->proc_name
= main_program
;
2316 gfc_commit_symbols ();
2320 /* Do whatever is necessary to accept the last statement. */
2323 accept_statement (gfc_statement st
)
2327 case ST_IMPLICIT_NONE
:
2335 gfc_current_ns
->proc_name
= gfc_new_block
;
2338 /* If the statement is the end of a block, lay down a special code
2339 that allows a branch to the end of the block from within the
2340 construct. IF and SELECT are treated differently from DO
2341 (where EXEC_NOP is added inside the loop) for two
2343 1. END DO has a meaning in the sense that after a GOTO to
2344 it, the loop counter must be increased.
2345 2. IF blocks and SELECT blocks can consist of multiple
2346 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
2347 Putting the label before the END IF would make the jump
2348 from, say, the ELSE IF block to the END IF illegal. */
2352 case ST_END_CRITICAL
:
2353 if (gfc_statement_label
!= NULL
)
2355 new_st
.op
= EXEC_END_NESTED_BLOCK
;
2360 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
2361 one parallel block. Thus, we add the special code to the nested block
2362 itself, instead of the parent one. */
2364 case ST_END_ASSOCIATE
:
2365 if (gfc_statement_label
!= NULL
)
2367 new_st
.op
= EXEC_END_BLOCK
;
2372 /* The end-of-program unit statements do not get the special
2373 marker and require a statement of some sort if they are a
2376 case ST_END_PROGRAM
:
2377 case ST_END_FUNCTION
:
2378 case ST_END_SUBROUTINE
:
2379 if (gfc_statement_label
!= NULL
)
2381 new_st
.op
= EXEC_RETURN
;
2386 new_st
.op
= EXEC_END_PROCEDURE
;
2402 gfc_commit_symbols ();
2403 gfc_warning_check ();
2404 gfc_clear_new_st ();
2408 /* Undo anything tentative that has been built for the current
2412 reject_statement (void)
2414 /* Revert to the previous charlen chain. */
2415 gfc_free_charlen (gfc_current_ns
->cl_list
, gfc_current_ns
->old_cl_list
);
2416 gfc_current_ns
->cl_list
= gfc_current_ns
->old_cl_list
;
2418 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
2419 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
2421 gfc_reject_data (gfc_current_ns
);
2423 gfc_new_block
= NULL
;
2424 gfc_undo_symbols ();
2425 gfc_clear_warning ();
2426 undo_new_statement ();
2430 /* Generic complaint about an out of order statement. We also do
2431 whatever is necessary to clean up. */
2434 unexpected_statement (gfc_statement st
)
2436 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
2438 reject_statement ();
2442 /* Given the next statement seen by the matcher, make sure that it is
2443 in proper order with the last. This subroutine is initialized by
2444 calling it with an argument of ST_NONE. If there is a problem, we
2445 issue an error and return false. Otherwise we return true.
2447 Individual parsers need to verify that the statements seen are
2448 valid before calling here, i.e., ENTRY statements are not allowed in
2449 INTERFACE blocks. The following diagram is taken from the standard:
2451 +---------------------------------------+
2452 | program subroutine function module |
2453 +---------------------------------------+
2455 +---------------------------------------+
2457 +---------------------------------------+
2459 | +-----------+------------------+
2460 | | parameter | implicit |
2461 | +-----------+------------------+
2462 | format | | derived type |
2463 | entry | parameter | interface |
2464 | | data | specification |
2465 | | | statement func |
2466 | +-----------+------------------+
2467 | | data | executable |
2468 +--------+-----------+------------------+
2470 +---------------------------------------+
2471 | internal module/subprogram |
2472 +---------------------------------------+
2474 +---------------------------------------+
2483 ORDER_IMPLICIT_NONE
,
2491 enum state_order state
;
2492 gfc_statement last_statement
;
2498 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
2504 p
->state
= ORDER_START
;
2508 if (p
->state
> ORDER_USE
)
2510 p
->state
= ORDER_USE
;
2514 if (p
->state
> ORDER_IMPORT
)
2516 p
->state
= ORDER_IMPORT
;
2519 case ST_IMPLICIT_NONE
:
2520 if (p
->state
> ORDER_IMPLICIT
)
2523 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2524 statement disqualifies a USE but not an IMPLICIT NONE.
2525 Duplicate IMPLICIT NONEs are caught when the implicit types
2528 p
->state
= ORDER_IMPLICIT_NONE
;
2532 if (p
->state
> ORDER_IMPLICIT
)
2534 p
->state
= ORDER_IMPLICIT
;
2539 if (p
->state
< ORDER_IMPLICIT_NONE
)
2540 p
->state
= ORDER_IMPLICIT_NONE
;
2544 if (p
->state
>= ORDER_EXEC
)
2546 if (p
->state
< ORDER_IMPLICIT
)
2547 p
->state
= ORDER_IMPLICIT
;
2551 if (p
->state
< ORDER_SPEC
)
2552 p
->state
= ORDER_SPEC
;
2557 case ST_STRUCTURE_DECL
:
2558 case ST_DERIVED_DECL
:
2560 if (p
->state
>= ORDER_EXEC
)
2562 if (p
->state
< ORDER_SPEC
)
2563 p
->state
= ORDER_SPEC
;
2567 /* The OpenMP directives have to be somewhere in the specification
2568 part, but there are no further requirements on their ordering.
2569 Thus don't adjust p->state, just ignore them. */
2570 if (p
->state
>= ORDER_EXEC
)
2576 if (p
->state
< ORDER_EXEC
)
2577 p
->state
= ORDER_EXEC
;
2584 /* All is well, record the statement in case we need it next time. */
2585 p
->where
= gfc_current_locus
;
2586 p
->last_statement
= st
;
2591 gfc_error ("%s statement at %C cannot follow %s statement at %L",
2592 gfc_ascii_statement (st
),
2593 gfc_ascii_statement (p
->last_statement
), &p
->where
);
2599 /* Handle an unexpected end of file. This is a show-stopper... */
2601 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
2604 unexpected_eof (void)
2608 gfc_error ("Unexpected end of file in %qs", gfc_source_file
);
2610 /* Memory cleanup. Move to "second to last". */
2611 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
2614 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
2617 longjmp (eof_buf
, 1);
2621 /* Parse the CONTAINS section of a derived type definition. */
2623 gfc_access gfc_typebound_default_access
;
2626 parse_derived_contains (void)
2629 bool seen_private
= false;
2630 bool seen_comps
= false;
2631 bool error_flag
= false;
2634 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2635 gcc_assert (gfc_current_block ());
2637 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
2639 if (gfc_current_block ()->attr
.sequence
)
2640 gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
2641 " section at %C", gfc_current_block ()->name
);
2642 if (gfc_current_block ()->attr
.is_bind_c
)
2643 gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
2644 " section at %C", gfc_current_block ()->name
);
2646 accept_statement (ST_CONTAINS
);
2647 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
2649 gfc_typebound_default_access
= ACCESS_PUBLIC
;
2655 st
= next_statement ();
2663 gfc_error ("Components in TYPE at %C must precede CONTAINS");
2667 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
2670 accept_statement (ST_PROCEDURE
);
2675 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
2678 accept_statement (ST_GENERIC
);
2683 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
2687 accept_statement (ST_FINAL
);
2695 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
2696 "at %C with empty CONTAINS section")))
2699 /* ST_END_TYPE is accepted by parse_derived after return. */
2703 if (!gfc_find_state (COMP_MODULE
))
2705 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2712 gfc_error ("PRIVATE statement at %C must precede procedure"
2719 gfc_error ("Duplicate PRIVATE statement at %C");
2723 accept_statement (ST_PRIVATE
);
2724 gfc_typebound_default_access
= ACCESS_PRIVATE
;
2725 seen_private
= true;
2729 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2733 gfc_error ("Already inside a CONTAINS block at %C");
2737 unexpected_statement (st
);
2745 reject_statement ();
2749 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2755 /* Set attributes for the parent symbol based on the attributes of a component
2756 and raise errors if conflicting attributes are found for the component. */
2759 check_component (gfc_symbol
*sym
, gfc_component
*c
, gfc_component
**lockp
,
2760 gfc_component
**eventp
)
2762 bool coarray
, lock_type
, event_type
, allocatable
, pointer
;
2763 coarray
= lock_type
= event_type
= allocatable
= pointer
= false;
2764 gfc_component
*lock_comp
= NULL
, *event_comp
= NULL
;
2766 if (lockp
) lock_comp
= *lockp
;
2767 if (eventp
) event_comp
= *eventp
;
2769 /* Look for allocatable components. */
2770 if (c
->attr
.allocatable
2771 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2772 && CLASS_DATA (c
)->attr
.allocatable
)
2773 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
2774 && c
->ts
.u
.derived
->attr
.alloc_comp
))
2777 sym
->attr
.alloc_comp
= 1;
2780 /* Look for pointer components. */
2782 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2783 && CLASS_DATA (c
)->attr
.class_pointer
)
2784 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
2787 sym
->attr
.pointer_comp
= 1;
2790 /* Look for procedure pointer components. */
2791 if (c
->attr
.proc_pointer
2792 || (c
->ts
.type
== BT_DERIVED
2793 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
2794 sym
->attr
.proc_pointer_comp
= 1;
2796 /* Looking for coarray components. */
2797 if (c
->attr
.codimension
2798 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2799 && CLASS_DATA (c
)->attr
.codimension
))
2802 sym
->attr
.coarray_comp
= 1;
2805 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
2806 && !c
->attr
.pointer
)
2809 sym
->attr
.coarray_comp
= 1;
2812 /* Looking for lock_type components. */
2813 if ((c
->ts
.type
== BT_DERIVED
2814 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2815 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2816 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2817 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2818 == INTMOD_ISO_FORTRAN_ENV
2819 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2820 == ISOFORTRAN_LOCK_TYPE
)
2821 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
2822 && !allocatable
&& !pointer
))
2826 sym
->attr
.lock_comp
= 1;
2829 /* Looking for event_type components. */
2830 if ((c
->ts
.type
== BT_DERIVED
2831 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2832 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2833 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2834 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2835 == INTMOD_ISO_FORTRAN_ENV
2836 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2837 == ISOFORTRAN_EVENT_TYPE
)
2838 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.event_comp
2839 && !allocatable
&& !pointer
))
2843 sym
->attr
.event_comp
= 1;
2846 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2847 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2848 unless there are nondirect [allocatable or pointer] components
2849 involved (cf. 1.3.33.1 and 1.3.33.3). */
2851 if (pointer
&& !coarray
&& lock_type
)
2852 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2853 "codimension or be a subcomponent of a coarray, "
2854 "which is not possible as the component has the "
2855 "pointer attribute", c
->name
, &c
->loc
);
2856 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
2857 && c
->ts
.u
.derived
->attr
.lock_comp
)
2858 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2859 "of type LOCK_TYPE, which must have a codimension or be a "
2860 "subcomponent of a coarray", c
->name
, &c
->loc
);
2862 if (lock_type
&& allocatable
&& !coarray
)
2863 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
2864 "a codimension", c
->name
, &c
->loc
);
2865 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
2866 && c
->ts
.u
.derived
->attr
.lock_comp
)
2867 gfc_error ("Allocatable component %s at %L must have a codimension as "
2868 "it has a noncoarray subcomponent of type LOCK_TYPE",
2871 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
2872 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2873 "subcomponent of type LOCK_TYPE must have a codimension or "
2874 "be a subcomponent of a coarray. (Variables of type %s may "
2875 "not have a codimension as already a coarray "
2876 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
2878 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
2879 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2880 "subcomponent of type LOCK_TYPE must have a codimension or "
2881 "be a subcomponent of a coarray. (Variables of type %s may "
2882 "not have a codimension as %s at %L has a codimension or a "
2883 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
2884 sym
->name
, c
->name
, &c
->loc
);
2886 /* Similarly for EVENT TYPE. */
2888 if (pointer
&& !coarray
&& event_type
)
2889 gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
2890 "codimension or be a subcomponent of a coarray, "
2891 "which is not possible as the component has the "
2892 "pointer attribute", c
->name
, &c
->loc
);
2893 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
2894 && c
->ts
.u
.derived
->attr
.event_comp
)
2895 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2896 "of type EVENT_TYPE, which must have a codimension or be a "
2897 "subcomponent of a coarray", c
->name
, &c
->loc
);
2899 if (event_type
&& allocatable
&& !coarray
)
2900 gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
2901 "a codimension", c
->name
, &c
->loc
);
2902 else if (event_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
2903 && c
->ts
.u
.derived
->attr
.event_comp
)
2904 gfc_error ("Allocatable component %s at %L must have a codimension as "
2905 "it has a noncoarray subcomponent of type EVENT_TYPE",
2908 if (sym
->attr
.coarray_comp
&& !coarray
&& event_type
)
2909 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
2910 "subcomponent of type EVENT_TYPE must have a codimension or "
2911 "be a subcomponent of a coarray. (Variables of type %s may "
2912 "not have a codimension as already a coarray "
2913 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
2915 if (sym
->attr
.event_comp
&& coarray
&& !event_type
)
2916 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
2917 "subcomponent of type EVENT_TYPE must have a codimension or "
2918 "be a subcomponent of a coarray. (Variables of type %s may "
2919 "not have a codimension as %s at %L has a codimension or a "
2920 "coarray subcomponent)", event_comp
->name
, &event_comp
->loc
,
2921 sym
->name
, c
->name
, &c
->loc
);
2923 /* Look for private components. */
2924 if (sym
->component_access
== ACCESS_PRIVATE
2925 || c
->attr
.access
== ACCESS_PRIVATE
2926 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
2927 sym
->attr
.private_comp
= 1;
2929 if (lockp
) *lockp
= lock_comp
;
2930 if (eventp
) *eventp
= event_comp
;
2934 static void parse_struct_map (gfc_statement
);
2936 /* Parse a union component definition within a structure definition. */
2944 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
2947 accept_statement(ST_UNION
);
2948 push_state (&s
, COMP_UNION
, gfc_new_block
);
2955 st
= next_statement ();
2956 /* Only MAP declarations valid within a union. */
2963 accept_statement (ST_MAP
);
2964 parse_struct_map (ST_MAP
);
2965 /* Add a component to the union for each map. */
2966 if (!gfc_add_component (un
, gfc_new_block
->name
, &c
))
2968 gfc_internal_error ("failed to create map component '%s'",
2969 gfc_new_block
->name
);
2970 reject_statement ();
2973 c
->ts
.type
= BT_DERIVED
;
2974 c
->ts
.u
.derived
= gfc_new_block
;
2975 /* Normally components get their initialization expressions when they
2976 are created in decl.c (build_struct) so we can look through the
2977 flat component list for initializers during resolution. Unions and
2978 maps create components along with their type definitions so we
2979 have to generate initializers here. */
2980 c
->initializer
= gfc_default_initializer (&c
->ts
);
2985 accept_statement (ST_END_UNION
);
2989 unexpected_statement (st
);
2994 for (c
= un
->components
; c
; c
= c
->next
)
2995 check_component (un
, c
, &lock_comp
, &event_comp
);
2997 /* Add the union as a component in its parent structure. */
2999 if (!gfc_add_component (gfc_current_block (), un
->name
, &c
))
3001 gfc_internal_error ("failed to create union component '%s'", un
->name
);
3002 reject_statement ();
3005 c
->ts
.type
= BT_UNION
;
3006 c
->ts
.u
.derived
= un
;
3007 c
->initializer
= gfc_default_initializer (&c
->ts
);
3009 un
->attr
.zero_comp
= un
->components
== NULL
;
3013 /* Parse a STRUCTURE or MAP. */
3016 parse_struct_map (gfc_statement block
)
3022 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3023 gfc_compile_state comp
;
3026 if (block
== ST_STRUCTURE_DECL
)
3028 comp
= COMP_STRUCTURE
;
3029 ends
= ST_END_STRUCTURE
;
3033 gcc_assert (block
== ST_MAP
);
3038 accept_statement(block
);
3039 push_state (&s
, comp
, gfc_new_block
);
3041 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3044 while (compiling_type
)
3046 st
= next_statement ();
3052 /* Nested structure declarations will be captured as ST_DATA_DECL. */
3053 case ST_STRUCTURE_DECL
:
3054 /* Let a more specific error make it to decode_statement(). */
3055 if (gfc_error_check () == 0)
3056 gfc_error ("Syntax error in nested structure declaration at %C");
3057 reject_statement ();
3058 /* Skip the rest of this statement. */
3059 gfc_error_recovery ();
3063 accept_statement (ST_UNION
);
3068 /* The data declaration was a nested/ad-hoc STRUCTURE field. */
3069 accept_statement (ST_DATA_DECL
);
3070 if (gfc_new_block
&& gfc_new_block
!= gfc_current_block ()
3071 && gfc_new_block
->attr
.flavor
== FL_STRUCT
)
3072 parse_struct_map (ST_STRUCTURE_DECL
);
3075 case ST_END_STRUCTURE
:
3079 accept_statement (st
);
3083 unexpected_statement (st
);
3087 unexpected_statement (st
);
3092 /* Validate each component. */
3093 sym
= gfc_current_block ();
3094 for (c
= sym
->components
; c
; c
= c
->next
)
3095 check_component (sym
, c
, &lock_comp
, &event_comp
);
3097 sym
->attr
.zero_comp
= (sym
->components
== NULL
);
3099 /* Allow parse_union to find this structure to add to its list of maps. */
3100 if (block
== ST_MAP
)
3101 gfc_new_block
= gfc_current_block ();
3107 /* Parse a derived type. */
3110 parse_derived (void)
3112 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
3116 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3118 accept_statement (ST_DERIVED_DECL
);
3119 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
3121 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3128 while (compiling_type
)
3130 st
= next_statement ();
3138 accept_statement (st
);
3143 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
3150 if (!seen_component
)
3151 gfc_notify_std (GFC_STD_F2003
, "Derived type "
3152 "definition at %C without components");
3154 accept_statement (ST_END_TYPE
);
3158 if (!gfc_find_state (COMP_MODULE
))
3160 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3167 gfc_error ("PRIVATE statement at %C must precede "
3168 "structure components");
3173 gfc_error ("Duplicate PRIVATE statement at %C");
3175 s
.sym
->component_access
= ACCESS_PRIVATE
;
3177 accept_statement (ST_PRIVATE
);
3184 gfc_error ("SEQUENCE statement at %C must precede "
3185 "structure components");
3189 if (gfc_current_block ()->attr
.sequence
)
3190 gfc_warning (0, "SEQUENCE attribute at %C already specified in "
3195 gfc_error ("Duplicate SEQUENCE statement at %C");
3199 gfc_add_sequence (&gfc_current_block ()->attr
,
3200 gfc_current_block ()->name
, NULL
);
3204 gfc_notify_std (GFC_STD_F2003
,
3205 "CONTAINS block in derived type"
3206 " definition at %C");
3208 accept_statement (ST_CONTAINS
);
3209 parse_derived_contains ();
3213 unexpected_statement (st
);
3218 /* need to verify that all fields of the derived type are
3219 * interoperable with C if the type is declared to be bind(c)
3221 sym
= gfc_current_block ();
3222 for (c
= sym
->components
; c
; c
= c
->next
)
3223 check_component (sym
, c
, &lock_comp
, &event_comp
);
3225 if (!seen_component
)
3226 sym
->attr
.zero_comp
= 1;
3232 /* Parse an ENUM. */
3240 int seen_enumerator
= 0;
3242 push_state (&s
, COMP_ENUM
, gfc_new_block
);
3246 while (compiling_enum
)
3248 st
= next_statement ();
3256 seen_enumerator
= 1;
3257 accept_statement (st
);
3262 if (!seen_enumerator
)
3263 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
3264 accept_statement (st
);
3268 gfc_free_enum_history ();
3269 unexpected_statement (st
);
3277 /* Parse an interface. We must be able to deal with the possibility
3278 of recursive interfaces. The parse_spec() subroutine is mutually
3279 recursive with parse_interface(). */
3281 static gfc_statement
parse_spec (gfc_statement
);
3284 parse_interface (void)
3286 gfc_compile_state new_state
= COMP_NONE
, current_state
;
3287 gfc_symbol
*prog_unit
, *sym
;
3288 gfc_interface_info save
;
3289 gfc_state_data s1
, s2
;
3292 accept_statement (ST_INTERFACE
);
3294 current_interface
.ns
= gfc_current_ns
;
3295 save
= current_interface
;
3297 sym
= (current_interface
.type
== INTERFACE_GENERIC
3298 || current_interface
.type
== INTERFACE_USER_OP
)
3299 ? gfc_new_block
: NULL
;
3301 push_state (&s1
, COMP_INTERFACE
, sym
);
3302 current_state
= COMP_NONE
;
3305 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
3307 st
= next_statement ();
3315 if (st
== ST_SUBROUTINE
)
3316 new_state
= COMP_SUBROUTINE
;
3317 else if (st
== ST_FUNCTION
)
3318 new_state
= COMP_FUNCTION
;
3319 if (gfc_new_block
->attr
.pointer
)
3321 gfc_new_block
->attr
.pointer
= 0;
3322 gfc_new_block
->attr
.proc_pointer
= 1;
3324 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
3325 gfc_new_block
->formal
, NULL
))
3327 reject_statement ();
3328 gfc_free_namespace (gfc_current_ns
);
3331 /* F2008 C1210 forbids the IMPORT statement in module procedure
3332 interface bodies and the flag is set to import symbols. */
3333 if (gfc_new_block
->attr
.module_procedure
)
3334 gfc_current_ns
->has_import_set
= 1;
3338 case ST_MODULE_PROC
: /* The module procedure matcher makes
3339 sure the context is correct. */
3340 accept_statement (st
);
3341 gfc_free_namespace (gfc_current_ns
);
3344 case ST_END_INTERFACE
:
3345 gfc_free_namespace (gfc_current_ns
);
3346 gfc_current_ns
= current_interface
.ns
;
3350 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
3351 gfc_ascii_statement (st
));
3352 reject_statement ();
3353 gfc_free_namespace (gfc_current_ns
);
3358 /* Make sure that the generic name has the right attribute. */
3359 if (current_interface
.type
== INTERFACE_GENERIC
3360 && current_state
== COMP_NONE
)
3362 if (new_state
== COMP_FUNCTION
&& sym
)
3363 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
3364 else if (new_state
== COMP_SUBROUTINE
&& sym
)
3365 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
3367 current_state
= new_state
;
3370 if (current_interface
.type
== INTERFACE_ABSTRACT
)
3372 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
3373 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
3374 gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
3375 "cannot be the same as an intrinsic type",
3376 gfc_new_block
->name
);
3379 push_state (&s2
, new_state
, gfc_new_block
);
3380 accept_statement (st
);
3381 prog_unit
= gfc_new_block
;
3382 prog_unit
->formal_ns
= gfc_current_ns
;
3383 if (prog_unit
== prog_unit
->formal_ns
->proc_name
3384 && prog_unit
->ns
!= prog_unit
->formal_ns
)
3388 /* Read data declaration statements. */
3389 st
= parse_spec (ST_NONE
);
3390 in_specification_block
= true;
3392 /* Since the interface block does not permit an IMPLICIT statement,
3393 the default type for the function or the result must be taken
3394 from the formal namespace. */
3395 if (new_state
== COMP_FUNCTION
)
3397 if (prog_unit
->result
== prog_unit
3398 && prog_unit
->ts
.type
== BT_UNKNOWN
)
3399 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
3400 else if (prog_unit
->result
!= prog_unit
3401 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
3402 gfc_set_default_type (prog_unit
->result
, 1,
3403 prog_unit
->formal_ns
);
3406 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
3408 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
3409 gfc_ascii_statement (st
));
3410 reject_statement ();
3414 /* Add EXTERNAL attribute to function or subroutine. */
3415 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
3416 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
3418 current_interface
= save
;
3419 gfc_add_interface (prog_unit
);
3422 if (current_interface
.ns
3423 && current_interface
.ns
->proc_name
3424 && strcmp (current_interface
.ns
->proc_name
->name
,
3425 prog_unit
->name
) == 0)
3426 gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
3427 "enclosing procedure", prog_unit
->name
,
3428 ¤t_interface
.ns
->proc_name
->declared_at
);
3437 /* Associate function characteristics by going back to the function
3438 declaration and rematching the prefix. */
3441 match_deferred_characteristics (gfc_typespec
* ts
)
3444 match m
= MATCH_ERROR
;
3445 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3447 loc
= gfc_current_locus
;
3449 gfc_current_locus
= gfc_current_block ()->declared_at
;
3452 gfc_buffer_error (true);
3453 m
= gfc_match_prefix (ts
);
3454 gfc_buffer_error (false);
3456 if (ts
->type
== BT_DERIVED
)
3464 /* Only permit one go at the characteristic association. */
3468 /* Set the function locus correctly. If we have not found the
3469 function name, there is an error. */
3471 && gfc_match ("function% %n", name
) == MATCH_YES
3472 && strcmp (name
, gfc_current_block ()->name
) == 0)
3474 gfc_current_block ()->declared_at
= gfc_current_locus
;
3475 gfc_commit_symbols ();
3480 gfc_undo_symbols ();
3483 gfc_current_locus
=loc
;
3488 /* Check specification-expressions in the function result of the currently
3489 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
3490 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
3491 scope are not yet parsed so this has to be delayed up to parse_spec. */
3494 check_function_result_typed (void)
3498 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
3500 if (!gfc_current_ns
->proc_name
->result
) return;
3502 ts
= gfc_current_ns
->proc_name
->result
->ts
;
3504 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
3505 /* TODO: Extend when KIND type parameters are implemented. */
3506 if (ts
.type
== BT_CHARACTER
&& ts
.u
.cl
&& ts
.u
.cl
->length
)
3507 gfc_expr_check_typed (ts
.u
.cl
->length
, gfc_current_ns
, true);
3511 /* Parse a set of specification statements. Returns the statement
3512 that doesn't fit. */
3514 static gfc_statement
3515 parse_spec (gfc_statement st
)
3518 bool function_result_typed
= false;
3519 bool bad_characteristic
= false;
3522 in_specification_block
= true;
3524 verify_st_order (&ss
, ST_NONE
, false);
3526 st
= next_statement ();
3528 /* If we are not inside a function or don't have a result specified so far,
3529 do nothing special about it. */
3530 if (gfc_current_state () != COMP_FUNCTION
)
3531 function_result_typed
= true;
3534 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
3537 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
3538 function_result_typed
= true;
3543 /* If we're inside a BLOCK construct, some statements are disallowed.
3544 Check this here. Attribute declaration statements like INTENT, OPTIONAL
3545 or VALUE are also disallowed, but they don't have a particular ST_*
3546 key so we have to check for them individually in their matcher routine. */
3547 if (gfc_current_state () == COMP_BLOCK
)
3551 case ST_IMPLICIT_NONE
:
3554 case ST_EQUIVALENCE
:
3555 case ST_STATEMENT_FUNCTION
:
3556 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
3557 gfc_ascii_statement (st
));
3558 reject_statement ();
3564 else if (gfc_current_state () == COMP_BLOCK_DATA
)
3565 /* Fortran 2008, C1116. */
3572 case ST_END_BLOCK_DATA
:
3574 case ST_EQUIVALENCE
:
3577 case ST_IMPLICIT_NONE
:
3578 case ST_DERIVED_DECL
:
3586 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
3587 gfc_ascii_statement (st
));
3588 reject_statement ();
3592 /* If we find a statement that can not be followed by an IMPLICIT statement
3593 (and thus we can expect to see none any further), type the function result
3594 if it has not yet been typed. Be careful not to give the END statement
3595 to verify_st_order! */
3596 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
3598 bool verify_now
= false;
3600 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
3605 verify_st_order (&dummyss
, ST_NONE
, false);
3606 verify_st_order (&dummyss
, st
, false);
3608 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
3614 check_function_result_typed ();
3615 function_result_typed
= true;
3624 case ST_IMPLICIT_NONE
:
3626 if (!function_result_typed
)
3628 check_function_result_typed ();
3629 function_result_typed
= true;
3635 case ST_DATA
: /* Not allowed in interfaces */
3636 if (gfc_current_state () == COMP_INTERFACE
)
3646 case ST_STRUCTURE_DECL
:
3647 case ST_DERIVED_DECL
:
3651 if (!verify_st_order (&ss
, st
, false))
3653 reject_statement ();
3654 st
= next_statement ();
3664 case ST_STRUCTURE_DECL
:
3665 parse_struct_map (ST_STRUCTURE_DECL
);
3668 case ST_DERIVED_DECL
:
3674 if (gfc_current_state () != COMP_MODULE
)
3676 gfc_error ("%s statement must appear in a MODULE",
3677 gfc_ascii_statement (st
));
3678 reject_statement ();
3682 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
3684 gfc_error ("%s statement at %C follows another accessibility "
3685 "specification", gfc_ascii_statement (st
));
3686 reject_statement ();
3690 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
3691 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3695 case ST_STATEMENT_FUNCTION
:
3696 if (gfc_current_state () == COMP_MODULE
3697 || gfc_current_state () == COMP_SUBMODULE
)
3699 unexpected_statement (st
);
3707 accept_statement (st
);
3708 st
= next_statement ();
3712 accept_statement (st
);
3714 st
= next_statement ();
3717 case ST_GET_FCN_CHARACTERISTICS
:
3718 /* This statement triggers the association of a function's result
3720 ts
= &gfc_current_block ()->result
->ts
;
3721 if (match_deferred_characteristics (ts
) != MATCH_YES
)
3722 bad_characteristic
= true;
3724 st
= next_statement ();
3731 /* If match_deferred_characteristics failed, then there is an error. */
3732 if (bad_characteristic
)
3734 ts
= &gfc_current_block ()->result
->ts
;
3735 if (ts
->type
!= BT_DERIVED
)
3736 gfc_error ("Bad kind expression for function %qs at %L",
3737 gfc_current_block ()->name
,
3738 &gfc_current_block ()->declared_at
);
3740 gfc_error ("The type for function %qs at %L is not accessible",
3741 gfc_current_block ()->name
,
3742 &gfc_current_block ()->declared_at
);
3744 gfc_current_block ()->ts
.kind
= 0;
3745 /* Keep the derived type; if it's bad, it will be discovered later. */
3746 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
3747 ts
->type
= BT_UNKNOWN
;
3750 in_specification_block
= false;
3756 /* Parse a WHERE block, (not a simple WHERE statement). */
3759 parse_where_block (void)
3761 int seen_empty_else
;
3766 accept_statement (ST_WHERE_BLOCK
);
3767 top
= gfc_state_stack
->tail
;
3769 push_state (&s
, COMP_WHERE
, gfc_new_block
);
3771 d
= add_statement ();
3772 d
->expr1
= top
->expr1
;
3778 seen_empty_else
= 0;
3782 st
= next_statement ();
3788 case ST_WHERE_BLOCK
:
3789 parse_where_block ();
3794 accept_statement (st
);
3798 if (seen_empty_else
)
3800 gfc_error ("ELSEWHERE statement at %C follows previous "
3801 "unmasked ELSEWHERE");
3802 reject_statement ();
3806 if (new_st
.expr1
== NULL
)
3807 seen_empty_else
= 1;
3809 d
= new_level (gfc_state_stack
->head
);
3811 d
->expr1
= new_st
.expr1
;
3813 accept_statement (st
);
3818 accept_statement (st
);
3822 gfc_error ("Unexpected %s statement in WHERE block at %C",
3823 gfc_ascii_statement (st
));
3824 reject_statement ();
3828 while (st
!= ST_END_WHERE
);
3834 /* Parse a FORALL block (not a simple FORALL statement). */
3837 parse_forall_block (void)
3843 accept_statement (ST_FORALL_BLOCK
);
3844 top
= gfc_state_stack
->tail
;
3846 push_state (&s
, COMP_FORALL
, gfc_new_block
);
3848 d
= add_statement ();
3849 d
->op
= EXEC_FORALL
;
3854 st
= next_statement ();
3859 case ST_POINTER_ASSIGNMENT
:
3862 accept_statement (st
);
3865 case ST_WHERE_BLOCK
:
3866 parse_where_block ();
3869 case ST_FORALL_BLOCK
:
3870 parse_forall_block ();
3874 accept_statement (st
);
3881 gfc_error ("Unexpected %s statement in FORALL block at %C",
3882 gfc_ascii_statement (st
));
3884 reject_statement ();
3888 while (st
!= ST_END_FORALL
);
3894 static gfc_statement
parse_executable (gfc_statement
);
3896 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
3899 parse_if_block (void)
3908 accept_statement (ST_IF_BLOCK
);
3910 top
= gfc_state_stack
->tail
;
3911 push_state (&s
, COMP_IF
, gfc_new_block
);
3913 new_st
.op
= EXEC_IF
;
3914 d
= add_statement ();
3916 d
->expr1
= top
->expr1
;
3922 st
= parse_executable (ST_NONE
);
3932 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
3933 "statement at %L", &else_locus
);
3935 reject_statement ();
3939 d
= new_level (gfc_state_stack
->head
);
3941 d
->expr1
= new_st
.expr1
;
3943 accept_statement (st
);
3950 gfc_error ("Duplicate ELSE statements at %L and %C",
3952 reject_statement ();
3957 else_locus
= gfc_current_locus
;
3959 d
= new_level (gfc_state_stack
->head
);
3962 accept_statement (st
);
3970 unexpected_statement (st
);
3974 while (st
!= ST_ENDIF
);
3977 accept_statement (st
);
3981 /* Parse a SELECT block. */
3984 parse_select_block (void)
3990 accept_statement (ST_SELECT_CASE
);
3992 cp
= gfc_state_stack
->tail
;
3993 push_state (&s
, COMP_SELECT
, gfc_new_block
);
3995 /* Make sure that the next statement is a CASE or END SELECT. */
3998 st
= next_statement ();
4001 if (st
== ST_END_SELECT
)
4003 /* Empty SELECT CASE is OK. */
4004 accept_statement (st
);
4011 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
4014 reject_statement ();
4017 /* At this point, we're got a nonempty select block. */
4018 cp
= new_level (cp
);
4021 accept_statement (st
);
4025 st
= parse_executable (ST_NONE
);
4032 cp
= new_level (gfc_state_stack
->head
);
4034 gfc_clear_new_st ();
4036 accept_statement (st
);
4042 /* Can't have an executable statement because of
4043 parse_executable(). */
4045 unexpected_statement (st
);
4049 while (st
!= ST_END_SELECT
);
4052 accept_statement (st
);
4056 /* Pop the current selector from the SELECT TYPE stack. */
4059 select_type_pop (void)
4061 gfc_select_type_stack
*old
= select_type_stack
;
4062 select_type_stack
= old
->prev
;
4067 /* Parse a SELECT TYPE construct (F03:R821). */
4070 parse_select_type_block (void)
4076 accept_statement (ST_SELECT_TYPE
);
4078 cp
= gfc_state_stack
->tail
;
4079 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
4081 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
4085 st
= next_statement ();
4088 if (st
== ST_END_SELECT
)
4089 /* Empty SELECT CASE is OK. */
4091 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
4094 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
4095 "following SELECT TYPE at %C");
4097 reject_statement ();
4100 /* At this point, we're got a nonempty select block. */
4101 cp
= new_level (cp
);
4104 accept_statement (st
);
4108 st
= parse_executable (ST_NONE
);
4116 cp
= new_level (gfc_state_stack
->head
);
4118 gfc_clear_new_st ();
4120 accept_statement (st
);
4126 /* Can't have an executable statement because of
4127 parse_executable(). */
4129 unexpected_statement (st
);
4133 while (st
!= ST_END_SELECT
);
4137 accept_statement (st
);
4138 gfc_current_ns
= gfc_current_ns
->parent
;
4143 /* Given a symbol, make sure it is not an iteration variable for a DO
4144 statement. This subroutine is called when the symbol is seen in a
4145 context that causes it to become redefined. If the symbol is an
4146 iterator, we generate an error message and return nonzero. */
4149 gfc_check_do_variable (gfc_symtree
*st
)
4153 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
4154 if (s
->do_variable
== st
)
4156 gfc_error_now ("Variable %qs at %C cannot be redefined inside "
4157 "loop beginning at %L", st
->name
, &s
->head
->loc
);
4165 /* Checks to see if the current statement label closes an enddo.
4166 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
4167 an error) if it incorrectly closes an ENDDO. */
4170 check_do_closure (void)
4174 if (gfc_statement_label
== NULL
)
4177 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
4178 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4182 return 0; /* No loops to close */
4184 if (p
->ext
.end_do_label
== gfc_statement_label
)
4186 if (p
== gfc_state_stack
)
4189 gfc_error ("End of nonblock DO statement at %C is within another block");
4193 /* At this point, the label doesn't terminate the innermost loop.
4194 Make sure it doesn't terminate another one. */
4195 for (; p
; p
= p
->previous
)
4196 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4197 && p
->ext
.end_do_label
== gfc_statement_label
)
4199 gfc_error ("End of nonblock DO statement at %C is interwoven "
4200 "with another DO loop");
4208 /* Parse a series of contained program units. */
4210 static void parse_progunit (gfc_statement
);
4213 /* Parse a CRITICAL block. */
4216 parse_critical_block (void)
4219 gfc_state_data s
, *sd
;
4222 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4223 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
4224 gfc_error_now (is_oacc (sd
)
4225 ? "CRITICAL block inside of OpenACC region at %C"
4226 : "CRITICAL block inside of OpenMP region at %C");
4228 s
.ext
.end_do_label
= new_st
.label1
;
4230 accept_statement (ST_CRITICAL
);
4231 top
= gfc_state_stack
->tail
;
4233 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
4235 d
= add_statement ();
4236 d
->op
= EXEC_CRITICAL
;
4241 st
= parse_executable (ST_NONE
);
4249 case ST_END_CRITICAL
:
4250 if (s
.ext
.end_do_label
!= NULL
4251 && s
.ext
.end_do_label
!= gfc_statement_label
)
4252 gfc_error_now ("Statement label in END CRITICAL at %C does not "
4253 "match CRITICAL label");
4255 if (gfc_statement_label
!= NULL
)
4257 new_st
.op
= EXEC_NOP
;
4263 unexpected_statement (st
);
4267 while (st
!= ST_END_CRITICAL
);
4270 accept_statement (st
);
4274 /* Set up the local namespace for a BLOCK construct. */
4277 gfc_build_block_ns (gfc_namespace
*parent_ns
)
4279 gfc_namespace
* my_ns
;
4280 static int numblock
= 1;
4282 my_ns
= gfc_get_namespace (parent_ns
, 1);
4283 my_ns
->construct_entities
= 1;
4285 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
4286 code generation (so it must not be NULL).
4287 We set its recursive argument if our container procedure is recursive, so
4288 that local variables are accordingly placed on the stack when it
4289 will be necessary. */
4291 my_ns
->proc_name
= gfc_new_block
;
4295 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
4297 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
4298 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
4299 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
4300 my_ns
->proc_name
->name
, NULL
);
4302 gfc_commit_symbol (my_ns
->proc_name
);
4305 if (parent_ns
->proc_name
)
4306 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
4312 /* Parse a BLOCK construct. */
4315 parse_block_construct (void)
4317 gfc_namespace
* my_ns
;
4318 gfc_namespace
* my_parent
;
4321 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
4323 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4325 new_st
.op
= EXEC_BLOCK
;
4326 new_st
.ext
.block
.ns
= my_ns
;
4327 new_st
.ext
.block
.assoc
= NULL
;
4328 accept_statement (ST_BLOCK
);
4330 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
4331 gfc_current_ns
= my_ns
;
4332 my_parent
= my_ns
->parent
;
4334 parse_progunit (ST_NONE
);
4336 /* Don't depend on the value of gfc_current_ns; it might have been
4337 reset if the block had errors and was cleaned up. */
4338 gfc_current_ns
= my_parent
;
4344 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
4345 behind the scenes with compiler-generated variables. */
4348 parse_associate (void)
4350 gfc_namespace
* my_ns
;
4353 gfc_association_list
* a
;
4355 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
4357 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4359 new_st
.op
= EXEC_BLOCK
;
4360 new_st
.ext
.block
.ns
= my_ns
;
4361 gcc_assert (new_st
.ext
.block
.assoc
);
4363 /* Add all associate-names as BLOCK variables. Creating them is enough
4364 for now, they'll get their values during trans-* phase. */
4365 gfc_current_ns
= my_ns
;
4366 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
4370 gfc_array_ref
*array_ref
;
4372 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
4376 sym
->attr
.flavor
= FL_VARIABLE
;
4378 sym
->declared_at
= a
->where
;
4379 gfc_set_sym_referenced (sym
);
4381 /* Initialize the typespec. It is not available in all cases,
4382 however, as it may only be set on the target during resolution.
4383 Still, sometimes it helps to have it right now -- especially
4384 for parsing component references on the associate-name
4385 in case of association to a derived-type. */
4386 sym
->ts
= a
->target
->ts
;
4388 /* Check if the target expression is array valued. This can not always
4389 be done by looking at target.rank, because that might not have been
4390 set yet. Therefore traverse the chain of refs, looking for the last
4391 array ref and evaluate that. */
4393 for (ref
= a
->target
->ref
; ref
; ref
= ref
->next
)
4394 if (ref
->type
== REF_ARRAY
)
4395 array_ref
= &ref
->u
.ar
;
4396 if (array_ref
|| a
->target
->rank
)
4403 /* Count the dimension, that have a non-scalar extend. */
4404 for (dim
= 0; dim
< array_ref
->dimen
; ++dim
)
4405 if (array_ref
->dimen_type
[dim
] != DIMEN_ELEMENT
4406 && !(array_ref
->dimen_type
[dim
] == DIMEN_UNKNOWN
4407 && array_ref
->end
[dim
] == NULL
4408 && array_ref
->start
[dim
] != NULL
))
4412 rank
= a
->target
->rank
;
4413 /* When the rank is greater than zero then sym will be an array. */
4414 if (sym
->ts
.type
== BT_CLASS
)
4416 if ((!CLASS_DATA (sym
)->as
&& rank
!= 0)
4417 || (CLASS_DATA (sym
)->as
4418 && CLASS_DATA (sym
)->as
->rank
!= rank
))
4420 /* Don't just (re-)set the attr and as in the sym.ts,
4421 because this modifies the target's attr and as. Copy the
4422 data and do a build_class_symbol. */
4423 symbol_attribute attr
= CLASS_DATA (a
->target
)->attr
;
4424 int corank
= gfc_get_corank (a
->target
);
4429 as
= gfc_get_array_spec ();
4430 as
->type
= AS_DEFERRED
;
4432 as
->corank
= corank
;
4433 attr
.dimension
= rank
? 1 : 0;
4434 attr
.codimension
= corank
? 1 : 0;
4439 attr
.dimension
= attr
.codimension
= 0;
4442 type
= CLASS_DATA (sym
)->ts
;
4443 if (!gfc_build_class_symbol (&type
,
4447 sym
->ts
.type
= BT_CLASS
;
4448 sym
->attr
.class_ok
= 1;
4451 sym
->attr
.class_ok
= 1;
4453 else if ((!sym
->as
&& rank
!= 0)
4454 || (sym
->as
&& sym
->as
->rank
!= rank
))
4456 as
= gfc_get_array_spec ();
4457 as
->type
= AS_DEFERRED
;
4459 as
->corank
= gfc_get_corank (a
->target
);
4461 sym
->attr
.dimension
= 1;
4463 sym
->attr
.codimension
= 1;
4468 accept_statement (ST_ASSOCIATE
);
4469 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
4472 st
= parse_executable (ST_NONE
);
4479 accept_statement (st
);
4480 my_ns
->code
= gfc_state_stack
->head
;
4484 unexpected_statement (st
);
4488 gfc_current_ns
= gfc_current_ns
->parent
;
4493 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
4494 handled inside of parse_executable(), because they aren't really
4498 parse_do_block (void)
4507 s
.ext
.end_do_label
= new_st
.label1
;
4509 if (new_st
.ext
.iterator
!= NULL
)
4510 stree
= new_st
.ext
.iterator
->var
->symtree
;
4514 accept_statement (ST_DO
);
4516 top
= gfc_state_stack
->tail
;
4517 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
4520 s
.do_variable
= stree
;
4522 top
->block
= new_level (top
);
4523 top
->block
->op
= EXEC_DO
;
4526 st
= parse_executable (ST_NONE
);
4534 if (s
.ext
.end_do_label
!= NULL
4535 && s
.ext
.end_do_label
!= gfc_statement_label
)
4536 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
4539 if (gfc_statement_label
!= NULL
)
4541 new_st
.op
= EXEC_NOP
;
4546 case ST_IMPLIED_ENDDO
:
4547 /* If the do-stmt of this DO construct has a do-construct-name,
4548 the corresponding end-do must be an end-do-stmt (with a matching
4549 name, but in that case we must have seen ST_ENDDO first).
4550 We only complain about this in pedantic mode. */
4551 if (gfc_current_block () != NULL
)
4552 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
4553 &gfc_current_block()->declared_at
);
4558 unexpected_statement (st
);
4563 accept_statement (st
);
4567 /* Parse the statements of OpenMP do/parallel do. */
4569 static gfc_statement
4570 parse_omp_do (gfc_statement omp_st
)
4576 accept_statement (omp_st
);
4578 cp
= gfc_state_stack
->tail
;
4579 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4580 np
= new_level (cp
);
4586 st
= next_statement ();
4589 else if (st
== ST_DO
)
4592 unexpected_statement (st
);
4596 if (gfc_statement_label
!= NULL
4597 && gfc_state_stack
->previous
!= NULL
4598 && gfc_state_stack
->previous
->state
== COMP_DO
4599 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4607 there should be no !$OMP END DO. */
4609 return ST_IMPLIED_ENDDO
;
4612 check_do_closure ();
4615 st
= next_statement ();
4616 gfc_statement omp_end_st
= ST_OMP_END_DO
;
4619 case ST_OMP_DISTRIBUTE
: omp_end_st
= ST_OMP_END_DISTRIBUTE
; break;
4620 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4621 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4623 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4624 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4626 case ST_OMP_DISTRIBUTE_SIMD
:
4627 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4629 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
4630 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
4631 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
4632 case ST_OMP_PARALLEL_DO_SIMD
:
4633 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
4635 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
4636 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4637 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4639 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4640 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4642 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4643 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4645 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4646 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4648 case ST_OMP_TEAMS_DISTRIBUTE
:
4649 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4651 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4652 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4654 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4655 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4657 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4658 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4660 default: gcc_unreachable ();
4662 if (st
== omp_end_st
)
4664 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
4665 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4667 gcc_assert (new_st
.op
== EXEC_NOP
);
4668 gfc_clear_new_st ();
4669 gfc_commit_symbols ();
4670 gfc_warning_check ();
4671 st
= next_statement ();
4677 /* Parse the statements of OpenMP atomic directive. */
4679 static gfc_statement
4680 parse_omp_oacc_atomic (bool omp_p
)
4682 gfc_statement st
, st_atomic
, st_end_atomic
;
4689 st_atomic
= ST_OMP_ATOMIC
;
4690 st_end_atomic
= ST_OMP_END_ATOMIC
;
4694 st_atomic
= ST_OACC_ATOMIC
;
4695 st_end_atomic
= ST_OACC_END_ATOMIC
;
4697 accept_statement (st_atomic
);
4699 cp
= gfc_state_stack
->tail
;
4700 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4701 np
= new_level (cp
);
4704 count
= 1 + ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4705 == GFC_OMP_ATOMIC_CAPTURE
);
4709 st
= next_statement ();
4712 else if (st
== ST_ASSIGNMENT
)
4714 accept_statement (st
);
4718 unexpected_statement (st
);
4723 st
= next_statement ();
4724 if (st
== st_end_atomic
)
4726 gfc_clear_new_st ();
4727 gfc_commit_symbols ();
4728 gfc_warning_check ();
4729 st
= next_statement ();
4731 else if ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4732 == GFC_OMP_ATOMIC_CAPTURE
)
4733 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
4738 /* Parse the statements of an OpenACC structured block. */
4741 parse_oacc_structured_block (gfc_statement acc_st
)
4743 gfc_statement st
, acc_end_st
;
4745 gfc_state_data s
, *sd
;
4747 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4748 if (sd
->state
== COMP_CRITICAL
)
4749 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4751 accept_statement (acc_st
);
4753 cp
= gfc_state_stack
->tail
;
4754 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4755 np
= new_level (cp
);
4760 case ST_OACC_PARALLEL
:
4761 acc_end_st
= ST_OACC_END_PARALLEL
;
4763 case ST_OACC_KERNELS
:
4764 acc_end_st
= ST_OACC_END_KERNELS
;
4767 acc_end_st
= ST_OACC_END_DATA
;
4769 case ST_OACC_HOST_DATA
:
4770 acc_end_st
= ST_OACC_END_HOST_DATA
;
4778 st
= parse_executable (ST_NONE
);
4781 else if (st
!= acc_end_st
)
4783 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
4784 reject_statement ();
4787 while (st
!= acc_end_st
);
4789 gcc_assert (new_st
.op
== EXEC_NOP
);
4791 gfc_clear_new_st ();
4792 gfc_commit_symbols ();
4793 gfc_warning_check ();
4797 /* Parse the statements of OpenACC loop/parallel loop/kernels loop. */
4799 static gfc_statement
4800 parse_oacc_loop (gfc_statement acc_st
)
4804 gfc_state_data s
, *sd
;
4806 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4807 if (sd
->state
== COMP_CRITICAL
)
4808 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4810 accept_statement (acc_st
);
4812 cp
= gfc_state_stack
->tail
;
4813 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4814 np
= new_level (cp
);
4820 st
= next_statement ();
4823 else if (st
== ST_DO
)
4827 gfc_error ("Expected DO loop at %C");
4828 reject_statement ();
4833 if (gfc_statement_label
!= NULL
4834 && gfc_state_stack
->previous
!= NULL
4835 && gfc_state_stack
->previous
->state
== COMP_DO
4836 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4839 return ST_IMPLIED_ENDDO
;
4842 check_do_closure ();
4845 st
= next_statement ();
4846 if (st
== ST_OACC_END_LOOP
)
4847 gfc_warning (0, "Redundant !$ACC END LOOP at %C");
4848 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
4849 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
4850 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
4852 gcc_assert (new_st
.op
== EXEC_NOP
);
4853 gfc_clear_new_st ();
4854 gfc_commit_symbols ();
4855 gfc_warning_check ();
4856 st
= next_statement ();
4862 /* Parse the statements of an OpenMP structured block. */
4865 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
4867 gfc_statement st
, omp_end_st
;
4871 accept_statement (omp_st
);
4873 cp
= gfc_state_stack
->tail
;
4874 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4875 np
= new_level (cp
);
4881 case ST_OMP_PARALLEL
:
4882 omp_end_st
= ST_OMP_END_PARALLEL
;
4884 case ST_OMP_PARALLEL_SECTIONS
:
4885 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
4887 case ST_OMP_SECTIONS
:
4888 omp_end_st
= ST_OMP_END_SECTIONS
;
4890 case ST_OMP_ORDERED
:
4891 omp_end_st
= ST_OMP_END_ORDERED
;
4893 case ST_OMP_CRITICAL
:
4894 omp_end_st
= ST_OMP_END_CRITICAL
;
4897 omp_end_st
= ST_OMP_END_MASTER
;
4900 omp_end_st
= ST_OMP_END_SINGLE
;
4903 omp_end_st
= ST_OMP_END_TARGET
;
4905 case ST_OMP_TARGET_DATA
:
4906 omp_end_st
= ST_OMP_END_TARGET_DATA
;
4908 case ST_OMP_TARGET_TEAMS
:
4909 omp_end_st
= ST_OMP_END_TARGET_TEAMS
;
4911 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4912 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4914 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4915 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4917 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4918 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4920 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4921 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4924 omp_end_st
= ST_OMP_END_TASK
;
4926 case ST_OMP_TASKGROUP
:
4927 omp_end_st
= ST_OMP_END_TASKGROUP
;
4930 omp_end_st
= ST_OMP_END_TEAMS
;
4932 case ST_OMP_TEAMS_DISTRIBUTE
:
4933 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4935 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4936 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4938 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4939 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4941 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4942 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4944 case ST_OMP_DISTRIBUTE
:
4945 omp_end_st
= ST_OMP_END_DISTRIBUTE
;
4947 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4948 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4950 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4951 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4953 case ST_OMP_DISTRIBUTE_SIMD
:
4954 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4956 case ST_OMP_WORKSHARE
:
4957 omp_end_st
= ST_OMP_END_WORKSHARE
;
4959 case ST_OMP_PARALLEL_WORKSHARE
:
4960 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
4968 if (workshare_stmts_only
)
4970 /* Inside of !$omp workshare, only
4973 where statements and constructs
4974 forall statements and constructs
4978 are allowed. For !$omp critical these
4979 restrictions apply recursively. */
4982 st
= next_statement ();
4993 accept_statement (st
);
4996 case ST_WHERE_BLOCK
:
4997 parse_where_block ();
5000 case ST_FORALL_BLOCK
:
5001 parse_forall_block ();
5004 case ST_OMP_PARALLEL
:
5005 case ST_OMP_PARALLEL_SECTIONS
:
5006 parse_omp_structured_block (st
, false);
5009 case ST_OMP_PARALLEL_WORKSHARE
:
5010 case ST_OMP_CRITICAL
:
5011 parse_omp_structured_block (st
, true);
5014 case ST_OMP_PARALLEL_DO
:
5015 case ST_OMP_PARALLEL_DO_SIMD
:
5016 st
= parse_omp_do (st
);
5020 st
= parse_omp_oacc_atomic (true);
5031 st
= next_statement ();
5035 st
= parse_executable (ST_NONE
);
5038 else if (st
== ST_OMP_SECTION
5039 && (omp_st
== ST_OMP_SECTIONS
5040 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
5042 np
= new_level (np
);
5046 else if (st
!= omp_end_st
)
5047 unexpected_statement (st
);
5049 while (st
!= omp_end_st
);
5053 case EXEC_OMP_END_NOWAIT
:
5054 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
5056 case EXEC_OMP_CRITICAL
:
5057 if (((cp
->ext
.omp_name
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
5058 || (new_st
.ext
.omp_name
!= NULL
5059 && strcmp (cp
->ext
.omp_name
, new_st
.ext
.omp_name
) != 0))
5060 gfc_error ("Name after !$omp critical and !$omp end critical does "
5062 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
5064 case EXEC_OMP_END_SINGLE
:
5065 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
5066 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
5067 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
5068 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
5076 gfc_clear_new_st ();
5077 gfc_commit_symbols ();
5078 gfc_warning_check ();
5083 /* Accept a series of executable statements. We return the first
5084 statement that doesn't fit to the caller. Any block statements are
5085 passed on to the correct handler, which usually passes the buck
5088 static gfc_statement
5089 parse_executable (gfc_statement st
)
5094 st
= next_statement ();
5098 close_flag
= check_do_closure ();
5103 case ST_END_PROGRAM
:
5106 case ST_END_FUNCTION
:
5111 case ST_END_SUBROUTINE
:
5116 case ST_SELECT_CASE
:
5117 gfc_error ("%s statement at %C cannot terminate a non-block "
5118 "DO loop", gfc_ascii_statement (st
));
5131 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
5132 "first executable statement");
5138 accept_statement (st
);
5139 if (close_flag
== 1)
5140 return ST_IMPLIED_ENDDO
;
5144 parse_block_construct ();
5155 case ST_SELECT_CASE
:
5156 parse_select_block ();
5159 case ST_SELECT_TYPE
:
5160 parse_select_type_block();
5165 if (check_do_closure () == 1)
5166 return ST_IMPLIED_ENDDO
;
5170 parse_critical_block ();
5173 case ST_WHERE_BLOCK
:
5174 parse_where_block ();
5177 case ST_FORALL_BLOCK
:
5178 parse_forall_block ();
5181 case ST_OACC_PARALLEL_LOOP
:
5182 case ST_OACC_KERNELS_LOOP
:
5184 st
= parse_oacc_loop (st
);
5185 if (st
== ST_IMPLIED_ENDDO
)
5189 case ST_OACC_PARALLEL
:
5190 case ST_OACC_KERNELS
:
5192 case ST_OACC_HOST_DATA
:
5193 parse_oacc_structured_block (st
);
5196 case ST_OMP_PARALLEL
:
5197 case ST_OMP_PARALLEL_SECTIONS
:
5198 case ST_OMP_SECTIONS
:
5199 case ST_OMP_ORDERED
:
5200 case ST_OMP_CRITICAL
:
5204 case ST_OMP_TARGET_DATA
:
5205 case ST_OMP_TARGET_TEAMS
:
5208 case ST_OMP_TASKGROUP
:
5209 parse_omp_structured_block (st
, false);
5212 case ST_OMP_WORKSHARE
:
5213 case ST_OMP_PARALLEL_WORKSHARE
:
5214 parse_omp_structured_block (st
, true);
5217 case ST_OMP_DISTRIBUTE
:
5218 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5219 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5220 case ST_OMP_DISTRIBUTE_SIMD
:
5222 case ST_OMP_DO_SIMD
:
5223 case ST_OMP_PARALLEL_DO
:
5224 case ST_OMP_PARALLEL_DO_SIMD
:
5226 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5227 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5228 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5229 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5230 case ST_OMP_TEAMS_DISTRIBUTE
:
5231 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5232 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5233 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5234 st
= parse_omp_do (st
);
5235 if (st
== ST_IMPLIED_ENDDO
)
5239 case ST_OACC_ATOMIC
:
5240 st
= parse_omp_oacc_atomic (false);
5244 st
= parse_omp_oacc_atomic (true);
5251 st
= next_statement ();
5256 /* Fix the symbols for sibling functions. These are incorrectly added to
5257 the child namespace as the parser didn't know about this procedure. */
5260 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
5264 gfc_symbol
*old_sym
;
5266 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
5268 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
5270 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
5271 goto fixup_contained
;
5273 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
5274 && sym
->attr
.generic
&& sym
->attr
.function
)
5275 ||(sym
->attr
.flavor
== FL_DERIVED
5276 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
5277 goto fixup_contained
;
5279 old_sym
= st
->n
.sym
;
5280 if (old_sym
->ns
== ns
5281 && !old_sym
->attr
.contained
5283 /* By 14.6.1.3, host association should be excluded
5284 for the following. */
5285 && !(old_sym
->attr
.external
5286 || (old_sym
->ts
.type
!= BT_UNKNOWN
5287 && !old_sym
->attr
.implicit_type
)
5288 || old_sym
->attr
.flavor
== FL_PARAMETER
5289 || old_sym
->attr
.use_assoc
5290 || old_sym
->attr
.in_common
5291 || old_sym
->attr
.in_equivalence
5292 || old_sym
->attr
.data
5293 || old_sym
->attr
.dummy
5294 || old_sym
->attr
.result
5295 || old_sym
->attr
.dimension
5296 || old_sym
->attr
.allocatable
5297 || old_sym
->attr
.intrinsic
5298 || old_sym
->attr
.generic
5299 || old_sym
->attr
.flavor
== FL_NAMELIST
5300 || old_sym
->attr
.flavor
== FL_LABEL
5301 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
5303 /* Replace it with the symbol from the parent namespace. */
5307 gfc_release_symbol (old_sym
);
5311 /* Do the same for any contained procedures. */
5312 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
5317 parse_contained (int module
)
5319 gfc_namespace
*ns
, *parent_ns
, *tmp
;
5320 gfc_state_data s1
, s2
;
5324 int contains_statements
= 0;
5327 push_state (&s1
, COMP_CONTAINS
, NULL
);
5328 parent_ns
= gfc_current_ns
;
5332 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
5334 gfc_current_ns
->sibling
= parent_ns
->contained
;
5335 parent_ns
->contained
= gfc_current_ns
;
5338 /* Process the next available statement. We come here if we got an error
5339 and rejected the last statement. */
5340 st
= next_statement ();
5349 contains_statements
= 1;
5350 accept_statement (st
);
5353 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
5356 /* For internal procedures, create/update the symbol in the
5357 parent namespace. */
5361 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
5362 gfc_error ("Contained procedure %qs at %C is already "
5363 "ambiguous", gfc_new_block
->name
);
5366 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
5368 &gfc_new_block
->declared_at
))
5370 if (st
== ST_FUNCTION
)
5371 gfc_add_function (&sym
->attr
, sym
->name
,
5372 &gfc_new_block
->declared_at
);
5374 gfc_add_subroutine (&sym
->attr
, sym
->name
,
5375 &gfc_new_block
->declared_at
);
5379 gfc_commit_symbols ();
5382 sym
= gfc_new_block
;
5384 /* Mark this as a contained function, so it isn't replaced
5385 by other module functions. */
5386 sym
->attr
.contained
= 1;
5388 /* Set implicit_pure so that it can be reset if any of the
5389 tests for purity fail. This is used for some optimisation
5390 during translation. */
5391 if (!sym
->attr
.pure
)
5392 sym
->attr
.implicit_pure
= 1;
5394 parse_progunit (ST_NONE
);
5396 /* Fix up any sibling functions that refer to this one. */
5397 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
5398 /* Or refer to any of its alternate entry points. */
5399 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
5400 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
5402 gfc_current_ns
->code
= s2
.head
;
5403 gfc_current_ns
= parent_ns
;
5408 /* These statements are associated with the end of the host unit. */
5409 case ST_END_FUNCTION
:
5411 case ST_END_SUBMODULE
:
5412 case ST_END_PROGRAM
:
5413 case ST_END_SUBROUTINE
:
5414 accept_statement (st
);
5415 gfc_current_ns
->code
= s1
.head
;
5419 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
5420 gfc_ascii_statement (st
));
5421 reject_statement ();
5427 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
5428 && st
!= ST_END_MODULE
&& st
!= ST_END_SUBMODULE
5429 && st
!= ST_END_PROGRAM
);
5431 /* The first namespace in the list is guaranteed to not have
5432 anything (worthwhile) in it. */
5433 tmp
= gfc_current_ns
;
5434 gfc_current_ns
= parent_ns
;
5435 if (seen_error
&& tmp
->refs
> 1)
5436 gfc_free_namespace (tmp
);
5438 ns
= gfc_current_ns
->contained
;
5439 gfc_current_ns
->contained
= ns
->sibling
;
5440 gfc_free_namespace (ns
);
5443 if (!contains_statements
)
5444 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
5445 "FUNCTION or SUBROUTINE statement at %C");
5449 /* The result variable in a MODULE PROCEDURE needs to be created and
5450 its characteristics copied from the interface since it is neither
5451 declared in the procedure declaration nor in the specification
5455 get_modproc_result (void)
5458 if (gfc_state_stack
->previous
5459 && gfc_state_stack
->previous
->state
== COMP_CONTAINS
5460 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
5462 proc
= gfc_current_ns
->proc_name
? gfc_current_ns
->proc_name
: NULL
;
5464 && proc
->attr
.function
5465 && proc
->ts
.interface
5466 && proc
->ts
.interface
->result
5467 && proc
->ts
.interface
->result
!= proc
->ts
.interface
)
5469 gfc_copy_dummy_sym (&proc
->result
, proc
->ts
.interface
->result
, 1);
5470 gfc_set_sym_referenced (proc
->result
);
5471 proc
->result
->attr
.if_source
= IFSRC_DECL
;
5472 gfc_commit_symbol (proc
->result
);
5478 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
5481 parse_progunit (gfc_statement st
)
5487 && gfc_new_block
->abr_modproc_decl
5488 && gfc_new_block
->attr
.function
)
5489 get_modproc_result ();
5491 st
= parse_spec (st
);
5498 /* This is not allowed within BLOCK! */
5499 if (gfc_current_state () != COMP_BLOCK
)
5504 accept_statement (st
);
5511 if (gfc_current_state () == COMP_FUNCTION
)
5512 gfc_check_function_type (gfc_current_ns
);
5517 st
= parse_executable (st
);
5525 /* This is not allowed within BLOCK! */
5526 if (gfc_current_state () != COMP_BLOCK
)
5531 accept_statement (st
);
5538 unexpected_statement (st
);
5539 reject_statement ();
5540 st
= next_statement ();
5546 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
5547 if (p
->state
== COMP_CONTAINS
)
5550 if (gfc_find_state (COMP_MODULE
) == true
5551 || gfc_find_state (COMP_SUBMODULE
) == true)
5556 gfc_error ("CONTAINS statement at %C is already in a contained "
5558 reject_statement ();
5559 st
= next_statement ();
5563 parse_contained (0);
5566 gfc_current_ns
->code
= gfc_state_stack
->head
;
5570 /* Come here to complain about a global symbol already in use as
5574 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
5579 where
= &gfc_current_locus
;
5589 case GSYM_SUBROUTINE
:
5590 name
= "SUBROUTINE";
5595 case GSYM_BLOCK_DATA
:
5596 name
= "BLOCK DATA";
5602 gfc_internal_error ("gfc_global_used(): Bad type");
5606 if (sym
->binding_label
)
5607 gfc_error ("Global binding name %qs at %L is already being used as a %s "
5608 "at %L", sym
->binding_label
, where
, name
, &sym
->where
);
5610 gfc_error ("Global name %qs at %L is already being used as a %s at %L",
5611 sym
->name
, where
, name
, &sym
->where
);
5615 /* Parse a block data program unit. */
5618 parse_block_data (void)
5621 static locus blank_locus
;
5622 static int blank_block
=0;
5625 gfc_current_ns
->proc_name
= gfc_new_block
;
5626 gfc_current_ns
->is_block_data
= 1;
5628 if (gfc_new_block
== NULL
)
5631 gfc_error ("Blank BLOCK DATA at %C conflicts with "
5632 "prior BLOCK DATA at %L", &blank_locus
);
5636 blank_locus
= gfc_current_locus
;
5641 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5643 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
5644 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5647 s
->type
= GSYM_BLOCK_DATA
;
5648 s
->where
= gfc_new_block
->declared_at
;
5653 st
= parse_spec (ST_NONE
);
5655 while (st
!= ST_END_BLOCK_DATA
)
5657 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
5658 gfc_ascii_statement (st
));
5659 reject_statement ();
5660 st
= next_statement ();
5665 /* Following the association of the ancestor (sub)module symbols, they
5666 must be set host rather than use associated and all must be public.
5667 They are flagged up by 'used_in_submodule' so that they can be set
5668 DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
5669 linker chokes on multiple symbol definitions. */
5672 set_syms_host_assoc (gfc_symbol
*sym
)
5679 if (sym
->attr
.module_procedure
)
5680 sym
->attr
.external
= 0;
5682 /* sym->attr.access = ACCESS_PUBLIC; */
5684 sym
->attr
.use_assoc
= 0;
5685 sym
->attr
.host_assoc
= 1;
5686 sym
->attr
.used_in_submodule
=1;
5688 if (sym
->attr
.flavor
== FL_DERIVED
)
5690 for (c
= sym
->components
; c
; c
= c
->next
)
5691 c
->attr
.access
= ACCESS_PUBLIC
;
5695 /* Parse a module subprogram. */
5704 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5705 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
5706 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5709 s
->type
= GSYM_MODULE
;
5710 s
->where
= gfc_new_block
->declared_at
;
5714 /* Something is nulling the module_list after this point. This is good
5715 since it allows us to 'USE' the parent modules that the submodule
5716 inherits and to set (most) of the symbols as host associated. */
5717 if (gfc_current_state () == COMP_SUBMODULE
)
5720 gfc_traverse_ns (gfc_current_ns
, set_syms_host_assoc
);
5723 st
= parse_spec (ST_NONE
);
5733 parse_contained (1);
5737 case ST_END_SUBMODULE
:
5738 accept_statement (st
);
5742 gfc_error ("Unexpected %s statement in MODULE at %C",
5743 gfc_ascii_statement (st
));
5746 reject_statement ();
5747 st
= next_statement ();
5751 /* Make sure not to free the namespace twice on error. */
5753 s
->ns
= gfc_current_ns
;
5757 /* Add a procedure name to the global symbol table. */
5760 add_global_procedure (bool sub
)
5764 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5765 name is a global identifier. */
5766 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5768 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5771 || (s
->type
!= GSYM_UNKNOWN
5772 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5774 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5775 /* Silence follow-up errors. */
5776 gfc_new_block
->binding_label
= NULL
;
5780 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5781 s
->sym_name
= gfc_new_block
->name
;
5782 s
->where
= gfc_new_block
->declared_at
;
5784 s
->ns
= gfc_current_ns
;
5788 /* Don't add the symbol multiple times. */
5789 if (gfc_new_block
->binding_label
5790 && (!gfc_notification_std (GFC_STD_F2008
)
5791 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
5793 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
);
5796 || (s
->type
!= GSYM_UNKNOWN
5797 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5799 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5800 /* Silence follow-up errors. */
5801 gfc_new_block
->binding_label
= NULL
;
5805 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5806 s
->sym_name
= gfc_new_block
->name
;
5807 s
->binding_label
= gfc_new_block
->binding_label
;
5808 s
->where
= gfc_new_block
->declared_at
;
5810 s
->ns
= gfc_current_ns
;
5816 /* Add a program to the global symbol table. */
5819 add_global_program (void)
5823 if (gfc_new_block
== NULL
)
5825 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5827 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
5828 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5831 s
->type
= GSYM_PROGRAM
;
5832 s
->where
= gfc_new_block
->declared_at
;
5834 s
->ns
= gfc_current_ns
;
5839 /* Resolve all the program units. */
5841 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
5843 gfc_free_dt_list ();
5844 gfc_current_ns
= gfc_global_ns_list
;
5845 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5847 if (gfc_current_ns
->proc_name
5848 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5849 continue; /* Already resolved. */
5851 if (gfc_current_ns
->proc_name
)
5852 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5853 gfc_resolve (gfc_current_ns
);
5854 gfc_current_ns
->derived_types
= gfc_derived_types
;
5855 gfc_derived_types
= NULL
;
5861 clean_up_modules (gfc_gsymbol
*gsym
)
5866 clean_up_modules (gsym
->left
);
5867 clean_up_modules (gsym
->right
);
5869 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
5872 gfc_current_ns
= gsym
->ns
;
5873 gfc_derived_types
= gfc_current_ns
->derived_types
;
5880 /* Translate all the program units. This could be in a different order
5881 to resolution if there are forward references in the file. */
5883 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
5887 gfc_current_ns
= gfc_global_ns_list
;
5888 gfc_get_errors (NULL
, &errors
);
5890 /* We first translate all modules to make sure that later parts
5891 of the program can use the decl. Then we translate the nonmodules. */
5893 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5895 if (!gfc_current_ns
->proc_name
5896 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5899 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5900 gfc_derived_types
= gfc_current_ns
->derived_types
;
5901 gfc_generate_module_code (gfc_current_ns
);
5902 gfc_current_ns
->translated
= 1;
5905 gfc_current_ns
= gfc_global_ns_list
;
5906 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5908 if (gfc_current_ns
->proc_name
5909 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5912 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5913 gfc_derived_types
= gfc_current_ns
->derived_types
;
5914 gfc_generate_code (gfc_current_ns
);
5915 gfc_current_ns
->translated
= 1;
5918 /* Clean up all the namespaces after translation. */
5919 gfc_current_ns
= gfc_global_ns_list
;
5920 for (;gfc_current_ns
;)
5924 if (gfc_current_ns
->proc_name
5925 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5927 gfc_current_ns
= gfc_current_ns
->sibling
;
5931 ns
= gfc_current_ns
->sibling
;
5932 gfc_derived_types
= gfc_current_ns
->derived_types
;
5934 gfc_current_ns
= ns
;
5937 clean_up_modules (gfc_gsym_root
);
5941 /* Top level parser. */
5944 gfc_parse_file (void)
5946 int seen_program
, errors_before
, errors
;
5947 gfc_state_data top
, s
;
5950 gfc_namespace
*next
;
5952 gfc_start_source_files ();
5954 top
.state
= COMP_NONE
;
5956 top
.previous
= NULL
;
5957 top
.head
= top
.tail
= NULL
;
5958 top
.do_variable
= NULL
;
5960 gfc_state_stack
= &top
;
5962 gfc_clear_new_st ();
5964 gfc_statement_label
= NULL
;
5966 if (setjmp (eof_buf
))
5967 return false; /* Come here on unexpected EOF */
5969 /* Prepare the global namespace that will contain the
5971 gfc_global_ns_list
= next
= NULL
;
5976 /* Exit early for empty files. */
5980 in_specification_block
= true;
5983 st
= next_statement ();
5992 goto duplicate_main
;
5994 prog_locus
= gfc_current_locus
;
5996 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
5997 main_program_symbol(gfc_current_ns
, gfc_new_block
->name
);
5998 accept_statement (st
);
5999 add_global_program ();
6000 parse_progunit (ST_NONE
);
6005 add_global_procedure (true);
6006 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
6007 accept_statement (st
);
6008 parse_progunit (ST_NONE
);
6013 add_global_procedure (false);
6014 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
6015 accept_statement (st
);
6016 parse_progunit (ST_NONE
);
6021 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
6022 accept_statement (st
);
6023 parse_block_data ();
6027 push_state (&s
, COMP_MODULE
, gfc_new_block
);
6028 accept_statement (st
);
6030 gfc_get_errors (NULL
, &errors_before
);
6035 push_state (&s
, COMP_SUBMODULE
, gfc_new_block
);
6036 accept_statement (st
);
6038 gfc_get_errors (NULL
, &errors_before
);
6042 /* Anything else starts a nameless main program block. */
6045 goto duplicate_main
;
6047 prog_locus
= gfc_current_locus
;
6049 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
6050 main_program_symbol (gfc_current_ns
, "MAIN__");
6051 parse_progunit (st
);
6056 /* Handle the non-program units. */
6057 gfc_current_ns
->code
= s
.head
;
6059 gfc_resolve (gfc_current_ns
);
6061 /* Dump the parse tree if requested. */
6062 if (flag_dump_fortran_original
)
6063 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6065 gfc_get_errors (NULL
, &errors
);
6066 if (s
.state
== COMP_MODULE
|| s
.state
== COMP_SUBMODULE
)
6068 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
6069 gfc_current_ns
->derived_types
= gfc_derived_types
;
6070 gfc_derived_types
= NULL
;
6076 gfc_generate_code (gfc_current_ns
);
6084 /* The main program and non-contained procedures are put
6085 in the global namespace list, so that they can be processed
6086 later and all their interfaces resolved. */
6087 gfc_current_ns
->code
= s
.head
;
6090 for (; next
->sibling
; next
= next
->sibling
)
6092 next
->sibling
= gfc_current_ns
;
6095 gfc_global_ns_list
= gfc_current_ns
;
6097 next
= gfc_current_ns
;
6104 /* Do the resolution. */
6105 resolve_all_program_units (gfc_global_ns_list
);
6107 /* Do the parse tree dump. */
6109 = flag_dump_fortran_original
? gfc_global_ns_list
: NULL
;
6111 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6112 if (!gfc_current_ns
->proc_name
6113 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6115 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6116 fputs ("------------------------------------------\n\n", stdout
);
6119 /* Do the translation. */
6120 translate_all_program_units (gfc_global_ns_list
);
6122 gfc_end_source_files ();
6126 /* If we see a duplicate main program, shut down. If the second
6127 instance is an implied main program, i.e. data decls or executable
6128 statements, we're in for lots of errors. */
6129 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
6130 reject_statement ();
6135 /* Return true if this state data represents an OpenACC region. */
6137 is_oacc (gfc_state_data
*sd
)
6139 switch (sd
->construct
->op
)
6141 case EXEC_OACC_PARALLEL_LOOP
:
6142 case EXEC_OACC_PARALLEL
:
6143 case EXEC_OACC_KERNELS_LOOP
:
6144 case EXEC_OACC_KERNELS
:
6145 case EXEC_OACC_DATA
:
6146 case EXEC_OACC_HOST_DATA
:
6147 case EXEC_OACC_LOOP
:
6148 case EXEC_OACC_UPDATE
:
6149 case EXEC_OACC_WAIT
:
6150 case EXEC_OACC_CACHE
:
6151 case EXEC_OACC_ENTER_DATA
:
6152 case EXEC_OACC_EXIT_DATA
:
6153 case EXEC_OACC_ATOMIC
:
6154 case EXEC_OACC_ROUTINE
: