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
);
194 match ("automatic", gfc_match_automatic
, ST_ATTR_DECL
);
198 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
202 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
203 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
207 match ("data", gfc_match_data
, ST_DATA
);
208 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
212 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
213 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
214 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
215 match ("external", gfc_match_external
, ST_ATTR_DECL
);
219 match ("format", gfc_match_format
, ST_FORMAT
);
226 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
227 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
228 match ("interface", gfc_match_interface
, ST_INTERFACE
);
229 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
230 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
237 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
241 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
245 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
246 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
247 if (gfc_match_private (&st
) == MATCH_YES
)
249 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
250 if (gfc_match_public (&st
) == MATCH_YES
)
252 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
259 match ("save", gfc_match_save
, ST_ATTR_DECL
);
260 match ("static", gfc_match_static
, ST_ATTR_DECL
);
261 match ("structure", gfc_match_structure_decl
, ST_STRUCTURE_DECL
);
265 match ("target", gfc_match_target
, ST_ATTR_DECL
);
266 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
273 match ("value", gfc_match_value
, ST_ATTR_DECL
);
274 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
281 /* This is not a specification statement. See if any of the matchers
282 has stored an error message of some sort. */
286 gfc_buffer_error (false);
287 gfc_current_locus
= old_locus
;
289 return ST_GET_FCN_CHARACTERISTICS
;
292 static bool in_specification_block
;
294 /* This is the primary 'decode_statement'. */
296 decode_statement (void)
303 gfc_enforce_clean_symbol_state ();
305 gfc_clear_error (); /* Clear any pending errors. */
306 gfc_clear_warning (); /* Clear any pending warnings. */
308 gfc_matching_function
= false;
310 if (gfc_match_eos () == MATCH_YES
)
313 if (gfc_current_state () == COMP_FUNCTION
314 && gfc_current_block ()->result
->ts
.kind
== -1)
315 return decode_specification_statement ();
317 old_locus
= gfc_current_locus
;
319 c
= gfc_peek_ascii_char ();
323 if (match_word ("use", gfc_match_use
, &old_locus
) == MATCH_YES
)
325 last_was_use_stmt
= true;
329 undo_new_statement ();
332 if (last_was_use_stmt
)
335 /* Try matching a data declaration or function declaration. The
336 input "REALFUNCTIONA(N)" can mean several things in different
337 contexts, so it (and its relatives) get special treatment. */
339 if (gfc_current_state () == COMP_NONE
340 || gfc_current_state () == COMP_INTERFACE
341 || gfc_current_state () == COMP_CONTAINS
)
343 gfc_matching_function
= true;
344 m
= gfc_match_function_decl ();
347 else if (m
== MATCH_ERROR
)
351 gfc_current_locus
= old_locus
;
353 gfc_matching_function
= false;
355 /* Legacy parameter statements are ambiguous with assignments so try parameter
357 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
359 /* Match statements whose error messages are meant to be overwritten
360 by something better. */
362 match (NULL
, gfc_match_assignment
, ST_ASSIGNMENT
);
363 match (NULL
, gfc_match_pointer_assignment
, ST_POINTER_ASSIGNMENT
);
365 if (in_specification_block
)
367 m
= match_word (NULL
, gfc_match_st_function
, &old_locus
);
369 return ST_STATEMENT_FUNCTION
;
372 if (!(in_specification_block
&& m
== MATCH_ERROR
))
374 match (NULL
, gfc_match_ptr_fcn_assign
, ST_ASSIGNMENT
);
377 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
378 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
380 /* Try to match a subroutine statement, which has the same optional
381 prefixes that functions can have. */
383 if (gfc_match_subroutine () == MATCH_YES
)
384 return ST_SUBROUTINE
;
386 gfc_current_locus
= old_locus
;
388 if (gfc_match_submod_proc () == MATCH_YES
)
390 if (gfc_new_block
->attr
.subroutine
)
391 return ST_SUBROUTINE
;
392 else if (gfc_new_block
->attr
.function
)
396 gfc_current_locus
= old_locus
;
398 /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
399 statements, which might begin with a block label. The match functions for
400 these statements are unusual in that their keyword is not seen before
401 the matcher is called. */
403 if (gfc_match_if (&st
) == MATCH_YES
)
406 gfc_current_locus
= old_locus
;
408 if (gfc_match_where (&st
) == MATCH_YES
)
411 gfc_current_locus
= old_locus
;
413 if (gfc_match_forall (&st
) == MATCH_YES
)
416 gfc_current_locus
= old_locus
;
418 /* Try to match TYPE as an alias for PRINT. */
419 if (gfc_match_type (&st
) == MATCH_YES
)
422 gfc_current_locus
= old_locus
;
424 match (NULL
, gfc_match_do
, ST_DO
);
425 match (NULL
, gfc_match_block
, ST_BLOCK
);
426 match (NULL
, gfc_match_associate
, ST_ASSOCIATE
);
427 match (NULL
, gfc_match_critical
, ST_CRITICAL
);
428 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
429 match (NULL
, gfc_match_select_type
, ST_SELECT_TYPE
);
431 /* General statement matching: Instead of testing every possible
432 statement, we eliminate most possibilities by peeking at the
438 match ("abstract% interface", gfc_match_abstract_interface
,
440 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
441 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
442 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
443 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
444 match ("automatic", gfc_match_automatic
, ST_ATTR_DECL
);
448 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
449 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
450 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
454 match ("call", gfc_match_call
, ST_CALL
);
455 match ("close", gfc_match_close
, ST_CLOSE
);
456 match ("continue", gfc_match_continue
, ST_CONTINUE
);
457 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
458 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
459 match ("case", gfc_match_case
, ST_CASE
);
460 match ("common", gfc_match_common
, ST_COMMON
);
461 match ("contains", gfc_match_eos
, ST_CONTAINS
);
462 match ("class", gfc_match_class_is
, ST_CLASS_IS
);
463 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
467 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
468 match ("data", gfc_match_data
, ST_DATA
);
469 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
473 match ("end file", gfc_match_endfile
, ST_END_FILE
);
474 match ("exit", gfc_match_exit
, ST_EXIT
);
475 match ("else", gfc_match_else
, ST_ELSE
);
476 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
477 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
478 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
);
479 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
481 if (gfc_match_end (&st
) == MATCH_YES
)
484 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
485 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
486 match ("external", gfc_match_external
, ST_ATTR_DECL
);
487 match ("event post", gfc_match_event_post
, ST_EVENT_POST
);
488 match ("event wait", gfc_match_event_wait
, ST_EVENT_WAIT
);
492 match ("final", gfc_match_final_decl
, ST_FINAL
);
493 match ("flush", gfc_match_flush
, ST_FLUSH
);
494 match ("format", gfc_match_format
, ST_FORMAT
);
498 match ("generic", gfc_match_generic
, ST_GENERIC
);
499 match ("go to", gfc_match_goto
, ST_GOTO
);
503 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
504 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
505 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
506 match ("import", gfc_match_import
, ST_IMPORT
);
507 match ("interface", gfc_match_interface
, ST_INTERFACE
);
508 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
509 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
513 match ("lock", gfc_match_lock
, ST_LOCK
);
517 match ("map", gfc_match_map
, ST_MAP
);
518 match ("module% procedure", gfc_match_modproc
, ST_MODULE_PROC
);
519 match ("module", gfc_match_module
, ST_MODULE
);
523 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
524 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
528 match ("open", gfc_match_open
, ST_OPEN
);
529 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
533 match ("print", gfc_match_print
, ST_WRITE
);
534 match ("pause", gfc_match_pause
, ST_PAUSE
);
535 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
536 if (gfc_match_private (&st
) == MATCH_YES
)
538 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
539 match ("program", gfc_match_program
, ST_PROGRAM
);
540 if (gfc_match_public (&st
) == MATCH_YES
)
542 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
546 match ("read", gfc_match_read
, ST_READ
);
547 match ("return", gfc_match_return
, ST_RETURN
);
548 match ("rewind", gfc_match_rewind
, ST_REWIND
);
552 match ("structure", gfc_match_structure_decl
, ST_STRUCTURE_DECL
);
553 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
554 match ("stop", gfc_match_stop
, ST_STOP
);
555 match ("save", gfc_match_save
, ST_ATTR_DECL
);
556 match ("static", gfc_match_static
, ST_ATTR_DECL
);
557 match ("submodule", gfc_match_submodule
, ST_SUBMODULE
);
558 match ("sync all", gfc_match_sync_all
, ST_SYNC_ALL
);
559 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
560 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
564 match ("target", gfc_match_target
, ST_ATTR_DECL
);
565 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
566 match ("type is", gfc_match_type_is
, ST_TYPE_IS
);
570 match ("union", gfc_match_union
, ST_UNION
);
571 match ("unlock", gfc_match_unlock
, ST_UNLOCK
);
575 match ("value", gfc_match_value
, ST_ATTR_DECL
);
576 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
580 match ("wait", gfc_match_wait
, ST_WAIT
);
581 match ("write", gfc_match_write
, ST_WRITE
);
585 /* All else has failed, so give up. See if any of the matchers has
586 stored an error message of some sort. */
588 if (!gfc_error_check ())
589 gfc_error_now ("Unclassifiable statement at %C");
593 gfc_error_recovery ();
598 /* Like match and if spec_only, goto do_spec_only without actually
600 #define matcha(keyword, subr, st) \
602 if (spec_only && gfc_match (keyword) == MATCH_YES) \
604 else if (match_word (keyword, subr, &old_locus) \
608 undo_new_statement (); \
612 decode_oacc_directive (void)
616 bool spec_only
= false;
618 gfc_enforce_clean_symbol_state ();
620 gfc_clear_error (); /* Clear any pending errors. */
621 gfc_clear_warning (); /* Clear any pending warnings. */
625 gfc_error_now ("OpenACC directives at %C may not appear in PURE "
627 gfc_error_recovery ();
631 if (gfc_current_state () == COMP_FUNCTION
632 && gfc_current_block ()->result
->ts
.kind
== -1)
635 gfc_unset_implicit_pure (NULL
);
637 old_locus
= gfc_current_locus
;
639 /* General OpenACC directive matching: Instead of testing every possible
640 statement, we eliminate most possibilities by peeking at the
643 c
= gfc_peek_ascii_char ();
648 matcha ("atomic", gfc_match_oacc_atomic
, ST_OACC_ATOMIC
);
651 matcha ("cache", gfc_match_oacc_cache
, ST_OACC_CACHE
);
654 matcha ("data", gfc_match_oacc_data
, ST_OACC_DATA
);
655 match ("declare", gfc_match_oacc_declare
, ST_OACC_DECLARE
);
658 matcha ("end atomic", gfc_match_omp_eos
, ST_OACC_END_ATOMIC
);
659 matcha ("end data", gfc_match_omp_eos
, ST_OACC_END_DATA
);
660 matcha ("end host_data", gfc_match_omp_eos
, ST_OACC_END_HOST_DATA
);
661 matcha ("end kernels loop", gfc_match_omp_eos
, ST_OACC_END_KERNELS_LOOP
);
662 matcha ("end kernels", gfc_match_omp_eos
, ST_OACC_END_KERNELS
);
663 matcha ("end loop", gfc_match_omp_eos
, ST_OACC_END_LOOP
);
664 matcha ("end parallel loop", gfc_match_omp_eos
,
665 ST_OACC_END_PARALLEL_LOOP
);
666 matcha ("end parallel", gfc_match_omp_eos
, ST_OACC_END_PARALLEL
);
667 matcha ("enter data", gfc_match_oacc_enter_data
, ST_OACC_ENTER_DATA
);
668 matcha ("exit data", gfc_match_oacc_exit_data
, ST_OACC_EXIT_DATA
);
671 matcha ("host_data", gfc_match_oacc_host_data
, ST_OACC_HOST_DATA
);
674 matcha ("parallel loop", gfc_match_oacc_parallel_loop
,
675 ST_OACC_PARALLEL_LOOP
);
676 matcha ("parallel", gfc_match_oacc_parallel
, ST_OACC_PARALLEL
);
679 matcha ("kernels loop", gfc_match_oacc_kernels_loop
,
680 ST_OACC_KERNELS_LOOP
);
681 matcha ("kernels", gfc_match_oacc_kernels
, ST_OACC_KERNELS
);
684 matcha ("loop", gfc_match_oacc_loop
, ST_OACC_LOOP
);
687 match ("routine", gfc_match_oacc_routine
, ST_OACC_ROUTINE
);
690 matcha ("update", gfc_match_oacc_update
, ST_OACC_UPDATE
);
693 matcha ("wait", gfc_match_oacc_wait
, ST_OACC_WAIT
);
697 /* Directive not found or stored an error message.
698 Check and give up. */
700 if (gfc_error_check () == 0)
701 gfc_error_now ("Unclassifiable OpenACC directive at %C");
705 gfc_error_recovery ();
712 gfc_buffer_error (false);
713 gfc_current_locus
= old_locus
;
714 return ST_GET_FCN_CHARACTERISTICS
;
717 /* Like match, but set a flag simd_matched if keyword matched
718 and if spec_only, goto do_spec_only without actually matching. */
719 #define matchs(keyword, subr, st) \
721 if (spec_only && gfc_match (keyword) == MATCH_YES) \
723 if (match_word_omp_simd (keyword, subr, &old_locus, \
724 &simd_matched) == MATCH_YES) \
727 undo_new_statement (); \
730 /* Like match, but don't match anything if not -fopenmp
731 and if spec_only, goto do_spec_only without actually matching. */
732 #define matcho(keyword, subr, st) \
736 else if (spec_only && gfc_match (keyword) == MATCH_YES) \
738 else if (match_word (keyword, subr, &old_locus) \
742 undo_new_statement (); \
745 /* Like match, but set a flag simd_matched if keyword matched. */
746 #define matchds(keyword, subr, st) \
748 if (match_word_omp_simd (keyword, subr, &old_locus, \
749 &simd_matched) == MATCH_YES) \
752 undo_new_statement (); \
755 /* Like match, but don't match anything if not -fopenmp. */
756 #define matchdo(keyword, subr, st) \
760 else if (match_word (keyword, subr, &old_locus) \
764 undo_new_statement (); \
768 decode_omp_directive (void)
772 bool simd_matched
= false;
773 bool spec_only
= false;
775 gfc_enforce_clean_symbol_state ();
777 gfc_clear_error (); /* Clear any pending errors. */
778 gfc_clear_warning (); /* Clear any pending warnings. */
782 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
783 "or ELEMENTAL procedures");
784 gfc_error_recovery ();
788 if (gfc_current_state () == COMP_FUNCTION
789 && gfc_current_block ()->result
->ts
.kind
== -1)
792 gfc_unset_implicit_pure (NULL
);
794 old_locus
= gfc_current_locus
;
796 /* General OpenMP directive matching: Instead of testing every possible
797 statement, we eliminate most possibilities by peeking at the
800 c
= gfc_peek_ascii_char ();
802 /* match is for directives that should be recognized only if
803 -fopenmp, matchs for directives that should be recognized
804 if either -fopenmp or -fopenmp-simd. */
808 matcho ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
811 matcho ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
814 matcho ("cancellation% point", gfc_match_omp_cancellation_point
,
815 ST_OMP_CANCELLATION_POINT
);
816 matcho ("cancel", gfc_match_omp_cancel
, ST_OMP_CANCEL
);
817 matcho ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
820 matchds ("declare reduction", gfc_match_omp_declare_reduction
,
821 ST_OMP_DECLARE_REDUCTION
);
822 matchds ("declare simd", gfc_match_omp_declare_simd
,
823 ST_OMP_DECLARE_SIMD
);
824 matchdo ("declare target", gfc_match_omp_declare_target
,
825 ST_OMP_DECLARE_TARGET
);
826 matchs ("distribute parallel do simd",
827 gfc_match_omp_distribute_parallel_do_simd
,
828 ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
);
829 matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do
,
830 ST_OMP_DISTRIBUTE_PARALLEL_DO
);
831 matchs ("distribute simd", gfc_match_omp_distribute_simd
,
832 ST_OMP_DISTRIBUTE_SIMD
);
833 matcho ("distribute", gfc_match_omp_distribute
, ST_OMP_DISTRIBUTE
);
834 matchs ("do simd", gfc_match_omp_do_simd
, ST_OMP_DO_SIMD
);
835 matcho ("do", gfc_match_omp_do
, ST_OMP_DO
);
838 matcho ("end atomic", gfc_match_omp_eos
, ST_OMP_END_ATOMIC
);
839 matcho ("end critical", gfc_match_omp_end_critical
, ST_OMP_END_CRITICAL
);
840 matchs ("end distribute parallel do simd", gfc_match_omp_eos
,
841 ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
);
842 matcho ("end distribute parallel do", gfc_match_omp_eos
,
843 ST_OMP_END_DISTRIBUTE_PARALLEL_DO
);
844 matchs ("end distribute simd", gfc_match_omp_eos
,
845 ST_OMP_END_DISTRIBUTE_SIMD
);
846 matcho ("end distribute", gfc_match_omp_eos
, ST_OMP_END_DISTRIBUTE
);
847 matchs ("end do simd", gfc_match_omp_end_nowait
, ST_OMP_END_DO_SIMD
);
848 matcho ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
849 matchs ("end simd", gfc_match_omp_eos
, ST_OMP_END_SIMD
);
850 matcho ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
851 matcho ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
852 matchs ("end parallel do simd", gfc_match_omp_eos
,
853 ST_OMP_END_PARALLEL_DO_SIMD
);
854 matcho ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
855 matcho ("end parallel sections", gfc_match_omp_eos
,
856 ST_OMP_END_PARALLEL_SECTIONS
);
857 matcho ("end parallel workshare", gfc_match_omp_eos
,
858 ST_OMP_END_PARALLEL_WORKSHARE
);
859 matcho ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
860 matcho ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
861 matcho ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
862 matcho ("end target data", gfc_match_omp_eos
, ST_OMP_END_TARGET_DATA
);
863 matchs ("end target parallel do simd", gfc_match_omp_eos
,
864 ST_OMP_END_TARGET_PARALLEL_DO_SIMD
);
865 matcho ("end target parallel do", gfc_match_omp_eos
,
866 ST_OMP_END_TARGET_PARALLEL_DO
);
867 matcho ("end target parallel", gfc_match_omp_eos
,
868 ST_OMP_END_TARGET_PARALLEL
);
869 matchs ("end target simd", gfc_match_omp_eos
, ST_OMP_END_TARGET_SIMD
);
870 matchs ("end target teams distribute parallel do simd",
872 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
873 matcho ("end target teams distribute parallel do", gfc_match_omp_eos
,
874 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
875 matchs ("end target teams distribute simd", gfc_match_omp_eos
,
876 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
);
877 matcho ("end target teams distribute", gfc_match_omp_eos
,
878 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
);
879 matcho ("end target teams", gfc_match_omp_eos
, ST_OMP_END_TARGET_TEAMS
);
880 matcho ("end target", gfc_match_omp_eos
, ST_OMP_END_TARGET
);
881 matcho ("end taskgroup", gfc_match_omp_eos
, ST_OMP_END_TASKGROUP
);
882 matchs ("end taskloop simd", gfc_match_omp_eos
,
883 ST_OMP_END_TASKLOOP_SIMD
);
884 matcho ("end taskloop", gfc_match_omp_eos
, ST_OMP_END_TASKLOOP
);
885 matcho ("end task", gfc_match_omp_eos
, ST_OMP_END_TASK
);
886 matchs ("end teams distribute parallel do simd", gfc_match_omp_eos
,
887 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
888 matcho ("end teams distribute parallel do", gfc_match_omp_eos
,
889 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
);
890 matchs ("end teams distribute simd", gfc_match_omp_eos
,
891 ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
);
892 matcho ("end teams distribute", gfc_match_omp_eos
,
893 ST_OMP_END_TEAMS_DISTRIBUTE
);
894 matcho ("end teams", gfc_match_omp_eos
, ST_OMP_END_TEAMS
);
895 matcho ("end workshare", gfc_match_omp_end_nowait
,
896 ST_OMP_END_WORKSHARE
);
899 matcho ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
902 matcho ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
905 if (flag_openmp
&& gfc_match ("ordered depend (") == MATCH_YES
)
907 gfc_current_locus
= old_locus
;
908 matcho ("ordered", gfc_match_omp_ordered_depend
,
909 ST_OMP_ORDERED_DEPEND
);
912 matcho ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
915 matchs ("parallel do simd", gfc_match_omp_parallel_do_simd
,
916 ST_OMP_PARALLEL_DO_SIMD
);
917 matcho ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
918 matcho ("parallel sections", gfc_match_omp_parallel_sections
,
919 ST_OMP_PARALLEL_SECTIONS
);
920 matcho ("parallel workshare", gfc_match_omp_parallel_workshare
,
921 ST_OMP_PARALLEL_WORKSHARE
);
922 matcho ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
925 matcho ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
926 matcho ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
927 matchs ("simd", gfc_match_omp_simd
, ST_OMP_SIMD
);
928 matcho ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
931 matcho ("target data", gfc_match_omp_target_data
, ST_OMP_TARGET_DATA
);
932 matcho ("target enter data", gfc_match_omp_target_enter_data
,
933 ST_OMP_TARGET_ENTER_DATA
);
934 matcho ("target exit data", gfc_match_omp_target_exit_data
,
935 ST_OMP_TARGET_EXIT_DATA
);
936 matchs ("target parallel do simd", gfc_match_omp_target_parallel_do_simd
,
937 ST_OMP_TARGET_PARALLEL_DO_SIMD
);
938 matcho ("target parallel do", gfc_match_omp_target_parallel_do
,
939 ST_OMP_TARGET_PARALLEL_DO
);
940 matcho ("target parallel", gfc_match_omp_target_parallel
,
941 ST_OMP_TARGET_PARALLEL
);
942 matchs ("target simd", gfc_match_omp_target_simd
, ST_OMP_TARGET_SIMD
);
943 matchs ("target teams distribute parallel do simd",
944 gfc_match_omp_target_teams_distribute_parallel_do_simd
,
945 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
946 matcho ("target teams distribute parallel do",
947 gfc_match_omp_target_teams_distribute_parallel_do
,
948 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
949 matchs ("target teams distribute simd",
950 gfc_match_omp_target_teams_distribute_simd
,
951 ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
);
952 matcho ("target teams distribute", gfc_match_omp_target_teams_distribute
,
953 ST_OMP_TARGET_TEAMS_DISTRIBUTE
);
954 matcho ("target teams", gfc_match_omp_target_teams
, ST_OMP_TARGET_TEAMS
);
955 matcho ("target update", gfc_match_omp_target_update
,
956 ST_OMP_TARGET_UPDATE
);
957 matcho ("target", gfc_match_omp_target
, ST_OMP_TARGET
);
958 matcho ("taskgroup", gfc_match_omp_taskgroup
, ST_OMP_TASKGROUP
);
959 matchs ("taskloop simd", gfc_match_omp_taskloop_simd
,
960 ST_OMP_TASKLOOP_SIMD
);
961 matcho ("taskloop", gfc_match_omp_taskloop
, ST_OMP_TASKLOOP
);
962 matcho ("taskwait", gfc_match_omp_taskwait
, ST_OMP_TASKWAIT
);
963 matcho ("taskyield", gfc_match_omp_taskyield
, ST_OMP_TASKYIELD
);
964 matcho ("task", gfc_match_omp_task
, ST_OMP_TASK
);
965 matchs ("teams distribute parallel do simd",
966 gfc_match_omp_teams_distribute_parallel_do_simd
,
967 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
968 matcho ("teams distribute parallel do",
969 gfc_match_omp_teams_distribute_parallel_do
,
970 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
);
971 matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd
,
972 ST_OMP_TEAMS_DISTRIBUTE_SIMD
);
973 matcho ("teams distribute", gfc_match_omp_teams_distribute
,
974 ST_OMP_TEAMS_DISTRIBUTE
);
975 matcho ("teams", gfc_match_omp_teams
, ST_OMP_TEAMS
);
976 matchdo ("threadprivate", gfc_match_omp_threadprivate
,
977 ST_OMP_THREADPRIVATE
);
980 matcho ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
984 /* All else has failed, so give up. See if any of the matchers has
985 stored an error message of some sort. Don't error out if
986 not -fopenmp and simd_matched is false, i.e. if a directive other
987 than one marked with match has been seen. */
989 if (flag_openmp
|| simd_matched
)
991 if (!gfc_error_check ())
992 gfc_error_now ("Unclassifiable OpenMP directive at %C");
997 gfc_error_recovery ();
1002 reject_statement ();
1004 gfc_buffer_error (false);
1005 gfc_current_locus
= old_locus
;
1006 return ST_GET_FCN_CHARACTERISTICS
;
1009 static gfc_statement
1010 decode_gcc_attribute (void)
1014 gfc_enforce_clean_symbol_state ();
1016 gfc_clear_error (); /* Clear any pending errors. */
1017 gfc_clear_warning (); /* Clear any pending warnings. */
1018 old_locus
= gfc_current_locus
;
1020 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
1022 /* All else has failed, so give up. See if any of the matchers has
1023 stored an error message of some sort. */
1025 if (!gfc_error_check ())
1026 gfc_error_now ("Unclassifiable GCC directive at %C");
1028 reject_statement ();
1030 gfc_error_recovery ();
1037 /* Assert next length characters to be equal to token in free form. */
1040 verify_token_free (const char* token
, int length
, bool last_was_use_stmt
)
1045 c
= gfc_next_ascii_char ();
1046 for (i
= 0; i
< length
; i
++, c
= gfc_next_ascii_char ())
1047 gcc_assert (c
== token
[i
]);
1049 gcc_assert (gfc_is_whitespace(c
));
1050 gfc_gobble_whitespace ();
1051 if (last_was_use_stmt
)
1055 /* Get the next statement in free form source. */
1057 static gfc_statement
1064 at_bol
= gfc_at_bol ();
1065 gfc_gobble_whitespace ();
1067 c
= gfc_peek_ascii_char ();
1073 /* Found a statement label? */
1074 m
= gfc_match_st_label (&gfc_statement_label
);
1076 d
= gfc_peek_ascii_char ();
1077 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
1079 gfc_match_small_literal_int (&i
, &cnt
);
1082 gfc_error_now ("Too many digits in statement label at %C");
1085 gfc_error_now ("Zero is not a valid statement label at %C");
1088 c
= gfc_next_ascii_char ();
1091 if (!gfc_is_whitespace (c
))
1092 gfc_error_now ("Non-numeric character in statement label at %C");
1098 label_locus
= gfc_current_locus
;
1100 gfc_gobble_whitespace ();
1102 if (at_bol
&& gfc_peek_ascii_char () == ';')
1104 gfc_error_now ("Semicolon at %C needs to be preceded by "
1106 gfc_next_ascii_char (); /* Eat up the semicolon. */
1110 if (gfc_match_eos () == MATCH_YES
)
1111 gfc_error_now ("Statement label without statement at %L",
1117 /* Comments have already been skipped by the time we get here,
1118 except for GCC attributes and OpenMP/OpenACC directives. */
1120 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
1121 c
= gfc_peek_ascii_char ();
1127 c
= gfc_next_ascii_char ();
1128 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
1129 gcc_assert (c
== "gcc$"[i
]);
1131 gfc_gobble_whitespace ();
1132 return decode_gcc_attribute ();
1137 /* Since both OpenMP and OpenACC directives starts with
1138 !$ character sequence, we must check all flags combinations */
1139 if ((flag_openmp
|| flag_openmp_simd
)
1142 verify_token_free ("$omp", 4, last_was_use_stmt
);
1143 return decode_omp_directive ();
1145 else if ((flag_openmp
|| flag_openmp_simd
)
1148 gfc_next_ascii_char (); /* Eat up dollar character */
1149 c
= gfc_peek_ascii_char ();
1153 verify_token_free ("omp", 3, last_was_use_stmt
);
1154 return decode_omp_directive ();
1158 verify_token_free ("acc", 3, last_was_use_stmt
);
1159 return decode_oacc_directive ();
1162 else if (flag_openacc
)
1164 verify_token_free ("$acc", 4, last_was_use_stmt
);
1165 return decode_oacc_directive ();
1171 if (at_bol
&& c
== ';')
1173 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1174 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1176 gfc_next_ascii_char (); /* Eat up the semicolon. */
1180 return decode_statement ();
1183 /* Assert next length characters to be equal to token in fixed form. */
1186 verify_token_fixed (const char *token
, int length
, bool last_was_use_stmt
)
1189 char c
= gfc_next_char_literal (NONSTRING
);
1191 for (i
= 0; i
< length
; i
++, c
= gfc_next_char_literal (NONSTRING
))
1192 gcc_assert ((char) gfc_wide_tolower (c
) == token
[i
]);
1194 if (c
!= ' ' && c
!= '0')
1196 gfc_buffer_error (false);
1197 gfc_error ("Bad continuation line at %C");
1200 if (last_was_use_stmt
)
1206 /* Get the next statement in fixed-form source. */
1208 static gfc_statement
1211 int label
, digit_flag
, i
;
1216 return decode_statement ();
1218 /* Skip past the current label field, parsing a statement label if
1219 one is there. This is a weird number parser, since the number is
1220 contained within five columns and can have any kind of embedded
1221 spaces. We also check for characters that make the rest of the
1227 for (i
= 0; i
< 5; i
++)
1229 c
= gfc_next_char_literal (NONSTRING
);
1246 label
= label
* 10 + ((unsigned char) c
- '0');
1247 label_locus
= gfc_current_locus
;
1251 /* Comments have already been skipped by the time we get
1252 here, except for GCC attributes and OpenMP directives. */
1255 c
= gfc_next_char_literal (NONSTRING
);
1257 if (TOLOWER (c
) == 'g')
1259 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
1260 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
1262 return decode_gcc_attribute ();
1266 if ((flag_openmp
|| flag_openmp_simd
)
1269 if (!verify_token_fixed ("omp", 3, last_was_use_stmt
))
1271 return decode_omp_directive ();
1273 else if ((flag_openmp
|| flag_openmp_simd
)
1276 c
= gfc_next_char_literal(NONSTRING
);
1277 if (c
== 'o' || c
== 'O')
1279 if (!verify_token_fixed ("mp", 2, last_was_use_stmt
))
1281 return decode_omp_directive ();
1283 else if (c
== 'a' || c
== 'A')
1285 if (!verify_token_fixed ("cc", 2, last_was_use_stmt
))
1287 return decode_oacc_directive ();
1290 else if (flag_openacc
)
1292 if (!verify_token_fixed ("acc", 3, last_was_use_stmt
))
1294 return decode_oacc_directive ();
1299 /* Comments have already been skipped by the time we get
1300 here so don't bother checking for them. */
1303 gfc_buffer_error (false);
1304 gfc_error ("Non-numeric character in statement label at %C");
1312 gfc_warning_now (0, "Zero is not a valid statement label at %C");
1315 /* We've found a valid statement label. */
1316 gfc_statement_label
= gfc_get_st_label (label
);
1320 /* Since this line starts a statement, it cannot be a continuation
1321 of a previous statement. If we see something here besides a
1322 space or zero, it must be a bad continuation line. */
1324 c
= gfc_next_char_literal (NONSTRING
);
1328 if (c
!= ' ' && c
!= '0')
1330 gfc_buffer_error (false);
1331 gfc_error ("Bad continuation line at %C");
1335 /* Now that we've taken care of the statement label columns, we have
1336 to make sure that the first nonblank character is not a '!'. If
1337 it is, the rest of the line is a comment. */
1341 loc
= gfc_current_locus
;
1342 c
= gfc_next_char_literal (NONSTRING
);
1344 while (gfc_is_whitespace (c
));
1348 gfc_current_locus
= loc
;
1353 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1354 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1355 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1360 if (gfc_match_eos () == MATCH_YES
)
1363 /* At this point, we've got a nonblank statement to parse. */
1364 return decode_statement ();
1368 gfc_error_now ("Statement label without statement at %L", &label_locus
);
1370 gfc_current_locus
.lb
->truncated
= 0;
1371 gfc_advance_line ();
1376 /* Return the next non-ST_NONE statement to the caller. We also worry
1377 about including files and the ends of include files at this stage. */
1379 static gfc_statement
1380 next_statement (void)
1385 gfc_enforce_clean_symbol_state ();
1387 gfc_new_block
= NULL
;
1389 gfc_current_ns
->old_cl_list
= gfc_current_ns
->cl_list
;
1390 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1391 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
1394 gfc_statement_label
= NULL
;
1395 gfc_buffer_error (true);
1398 gfc_advance_line ();
1400 gfc_skip_comments ();
1408 if (gfc_define_undef_line ())
1411 old_locus
= gfc_current_locus
;
1413 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1419 gfc_buffer_error (false);
1421 if (st
== ST_GET_FCN_CHARACTERISTICS
)
1423 if (gfc_statement_label
!= NULL
)
1425 gfc_free_st_label (gfc_statement_label
);
1426 gfc_statement_label
= NULL
;
1428 gfc_current_locus
= old_locus
;
1432 check_statement_label (st
);
1438 /****************************** Parser ***********************************/
1440 /* The parser subroutines are of type 'try' that fail if the file ends
1443 /* Macros that expand to case-labels for various classes of
1444 statements. Start with executable statements that directly do
1447 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1448 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1449 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1450 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1451 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1452 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1453 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1454 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1455 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1456 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
1457 case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
1458 case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: \
1459 case ST_ERROR_STOP: case ST_SYNC_ALL: \
1460 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1461 case ST_EVENT_POST: case ST_EVENT_WAIT: \
1462 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1463 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1465 /* Statements that mark other executable statements. */
1467 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1468 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1469 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1470 case ST_OMP_PARALLEL: \
1471 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1472 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
1473 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1474 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1475 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1476 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1477 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1478 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1479 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1480 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1481 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1482 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1483 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1484 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1485 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1486 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1487 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \
1488 case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \
1489 case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
1491 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1492 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
1493 case ST_OACC_KERNELS_LOOP: case ST_OACC_ATOMIC
1495 /* Declaration statements */
1497 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1498 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1499 case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE: case ST_OACC_ROUTINE: \
1500 case ST_OACC_DECLARE
1502 /* OpenMP declaration statements. */
1504 #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
1505 case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION
1507 /* Block end statements. Errors associated with interchanging these
1508 are detected in gfc_match_end(). */
1510 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1511 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1512 case ST_END_BLOCK: case ST_END_ASSOCIATE
1515 /* Push a new state onto the stack. */
1518 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1520 p
->state
= new_state
;
1521 p
->previous
= gfc_state_stack
;
1523 p
->head
= p
->tail
= NULL
;
1524 p
->do_variable
= NULL
;
1525 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1526 p
->ext
.oacc_declare_clauses
= NULL
;
1528 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1529 construct statement was accepted right before pushing the state. Thus,
1530 the construct's gfc_code is available as tail of the parent state. */
1531 gcc_assert (gfc_state_stack
);
1532 p
->construct
= gfc_state_stack
->tail
;
1534 gfc_state_stack
= p
;
1538 /* Pop the current state. */
1542 gfc_state_stack
= gfc_state_stack
->previous
;
1546 /* Try to find the given state in the state stack. */
1549 gfc_find_state (gfc_compile_state state
)
1553 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1554 if (p
->state
== state
)
1557 return (p
== NULL
) ? false : true;
1561 /* Starts a new level in the statement list. */
1564 new_level (gfc_code
*q
)
1568 p
= q
->block
= gfc_get_code (EXEC_NOP
);
1570 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1576 /* Add the current new_st code structure and adds it to the current
1577 program unit. As a side-effect, it zeroes the new_st. */
1580 add_statement (void)
1584 p
= XCNEW (gfc_code
);
1587 p
->loc
= gfc_current_locus
;
1589 if (gfc_state_stack
->head
== NULL
)
1590 gfc_state_stack
->head
= p
;
1592 gfc_state_stack
->tail
->next
= p
;
1594 while (p
->next
!= NULL
)
1597 gfc_state_stack
->tail
= p
;
1599 gfc_clear_new_st ();
1605 /* Frees everything associated with the current statement. */
1608 undo_new_statement (void)
1610 gfc_free_statements (new_st
.block
);
1611 gfc_free_statements (new_st
.next
);
1612 gfc_free_statement (&new_st
);
1613 gfc_clear_new_st ();
1617 /* If the current statement has a statement label, make sure that it
1618 is allowed to, or should have one. */
1621 check_statement_label (gfc_statement st
)
1625 if (gfc_statement_label
== NULL
)
1627 if (st
== ST_FORMAT
)
1628 gfc_error ("FORMAT statement at %L does not have a statement label",
1635 case ST_END_PROGRAM
:
1636 case ST_END_FUNCTION
:
1637 case ST_END_SUBROUTINE
:
1641 case ST_END_CRITICAL
:
1643 case ST_END_ASSOCIATE
:
1646 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
1647 type
= ST_LABEL_DO_TARGET
;
1649 type
= ST_LABEL_TARGET
;
1653 type
= ST_LABEL_FORMAT
;
1656 /* Statement labels are not restricted from appearing on a
1657 particular line. However, there are plenty of situations
1658 where the resulting label can't be referenced. */
1661 type
= ST_LABEL_BAD_TARGET
;
1665 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1667 new_st
.here
= gfc_statement_label
;
1671 /* Figures out what the enclosing program unit is. This will be a
1672 function, subroutine, program, block data or module. */
1675 gfc_enclosing_unit (gfc_compile_state
* result
)
1679 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1680 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1681 || p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
1682 || p
->state
== COMP_BLOCK_DATA
|| p
->state
== COMP_PROGRAM
)
1691 *result
= COMP_PROGRAM
;
1696 /* Translate a statement enum to a string. */
1699 gfc_ascii_statement (gfc_statement st
)
1705 case ST_ARITHMETIC_IF
:
1706 p
= _("arithmetic IF");
1715 p
= _("attribute declaration");
1751 p
= _("data declaration");
1765 case ST_STRUCTURE_DECL
:
1768 case ST_DERIVED_DECL
:
1769 p
= _("derived type declaration");
1789 case ST_END_ASSOCIATE
:
1790 p
= "END ASSOCIATE";
1795 case ST_END_BLOCK_DATA
:
1796 p
= "END BLOCK DATA";
1798 case ST_END_CRITICAL
:
1810 case ST_END_FUNCTION
:
1816 case ST_END_INTERFACE
:
1817 p
= "END INTERFACE";
1822 case ST_END_SUBMODULE
:
1823 p
= "END SUBMODULE";
1825 case ST_END_PROGRAM
:
1831 case ST_END_SUBROUTINE
:
1832 p
= "END SUBROUTINE";
1837 case ST_END_STRUCTURE
:
1838 p
= "END STRUCTURE";
1852 case ST_EQUIVALENCE
:
1864 case ST_FORALL_BLOCK
: /* Fall through */
1886 case ST_IMPLICIT_NONE
:
1887 p
= "IMPLICIT NONE";
1889 case ST_IMPLIED_ENDDO
:
1890 p
= _("implied END DO");
1922 case ST_MODULE_PROC
:
1923 p
= "MODULE PROCEDURE";
1955 case ST_SYNC_IMAGES
:
1958 case ST_SYNC_MEMORY
:
1973 case ST_WHERE_BLOCK
: /* Fall through */
1984 p
= _("assignment");
1986 case ST_POINTER_ASSIGNMENT
:
1987 p
= _("pointer assignment");
1989 case ST_SELECT_CASE
:
1992 case ST_SELECT_TYPE
:
2007 case ST_STATEMENT_FUNCTION
:
2008 p
= "STATEMENT FUNCTION";
2010 case ST_LABEL_ASSIGNMENT
:
2011 p
= "LABEL ASSIGNMENT";
2014 p
= "ENUM DEFINITION";
2017 p
= "ENUMERATOR DEFINITION";
2022 case ST_OACC_PARALLEL_LOOP
:
2023 p
= "!$ACC PARALLEL LOOP";
2025 case ST_OACC_END_PARALLEL_LOOP
:
2026 p
= "!$ACC END PARALLEL LOOP";
2028 case ST_OACC_PARALLEL
:
2029 p
= "!$ACC PARALLEL";
2031 case ST_OACC_END_PARALLEL
:
2032 p
= "!$ACC END PARALLEL";
2034 case ST_OACC_KERNELS
:
2035 p
= "!$ACC KERNELS";
2037 case ST_OACC_END_KERNELS
:
2038 p
= "!$ACC END KERNELS";
2040 case ST_OACC_KERNELS_LOOP
:
2041 p
= "!$ACC KERNELS LOOP";
2043 case ST_OACC_END_KERNELS_LOOP
:
2044 p
= "!$ACC END KERNELS LOOP";
2049 case ST_OACC_END_DATA
:
2050 p
= "!$ACC END DATA";
2052 case ST_OACC_HOST_DATA
:
2053 p
= "!$ACC HOST_DATA";
2055 case ST_OACC_END_HOST_DATA
:
2056 p
= "!$ACC END HOST_DATA";
2061 case ST_OACC_END_LOOP
:
2062 p
= "!$ACC END LOOP";
2064 case ST_OACC_DECLARE
:
2065 p
= "!$ACC DECLARE";
2067 case ST_OACC_UPDATE
:
2076 case ST_OACC_ENTER_DATA
:
2077 p
= "!$ACC ENTER DATA";
2079 case ST_OACC_EXIT_DATA
:
2080 p
= "!$ACC EXIT DATA";
2082 case ST_OACC_ROUTINE
:
2083 p
= "!$ACC ROUTINE";
2085 case ST_OACC_ATOMIC
:
2088 case ST_OACC_END_ATOMIC
:
2089 p
= "!ACC END ATOMIC";
2094 case ST_OMP_BARRIER
:
2095 p
= "!$OMP BARRIER";
2100 case ST_OMP_CANCELLATION_POINT
:
2101 p
= "!$OMP CANCELLATION POINT";
2103 case ST_OMP_CRITICAL
:
2104 p
= "!$OMP CRITICAL";
2106 case ST_OMP_DECLARE_REDUCTION
:
2107 p
= "!$OMP DECLARE REDUCTION";
2109 case ST_OMP_DECLARE_SIMD
:
2110 p
= "!$OMP DECLARE SIMD";
2112 case ST_OMP_DECLARE_TARGET
:
2113 p
= "!$OMP DECLARE TARGET";
2115 case ST_OMP_DISTRIBUTE
:
2116 p
= "!$OMP DISTRIBUTE";
2118 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
2119 p
= "!$OMP DISTRIBUTE PARALLEL DO";
2121 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2122 p
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
2124 case ST_OMP_DISTRIBUTE_SIMD
:
2125 p
= "!$OMP DISTRIBUTE SIMD";
2130 case ST_OMP_DO_SIMD
:
2131 p
= "!$OMP DO SIMD";
2133 case ST_OMP_END_ATOMIC
:
2134 p
= "!$OMP END ATOMIC";
2136 case ST_OMP_END_CRITICAL
:
2137 p
= "!$OMP END CRITICAL";
2139 case ST_OMP_END_DISTRIBUTE
:
2140 p
= "!$OMP END DISTRIBUTE";
2142 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO
:
2143 p
= "!$OMP END DISTRIBUTE PARALLEL DO";
2145 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
:
2146 p
= "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
2148 case ST_OMP_END_DISTRIBUTE_SIMD
:
2149 p
= "!$OMP END DISTRIBUTE SIMD";
2154 case ST_OMP_END_DO_SIMD
:
2155 p
= "!$OMP END DO SIMD";
2157 case ST_OMP_END_SIMD
:
2158 p
= "!$OMP END SIMD";
2160 case ST_OMP_END_MASTER
:
2161 p
= "!$OMP END MASTER";
2163 case ST_OMP_END_ORDERED
:
2164 p
= "!$OMP END ORDERED";
2166 case ST_OMP_END_PARALLEL
:
2167 p
= "!$OMP END PARALLEL";
2169 case ST_OMP_END_PARALLEL_DO
:
2170 p
= "!$OMP END PARALLEL DO";
2172 case ST_OMP_END_PARALLEL_DO_SIMD
:
2173 p
= "!$OMP END PARALLEL DO SIMD";
2175 case ST_OMP_END_PARALLEL_SECTIONS
:
2176 p
= "!$OMP END PARALLEL SECTIONS";
2178 case ST_OMP_END_PARALLEL_WORKSHARE
:
2179 p
= "!$OMP END PARALLEL WORKSHARE";
2181 case ST_OMP_END_SECTIONS
:
2182 p
= "!$OMP END SECTIONS";
2184 case ST_OMP_END_SINGLE
:
2185 p
= "!$OMP END SINGLE";
2187 case ST_OMP_END_TASK
:
2188 p
= "!$OMP END TASK";
2190 case ST_OMP_END_TARGET
:
2191 p
= "!$OMP END TARGET";
2193 case ST_OMP_END_TARGET_DATA
:
2194 p
= "!$OMP END TARGET DATA";
2196 case ST_OMP_END_TARGET_PARALLEL
:
2197 p
= "!$OMP END TARGET PARALLEL";
2199 case ST_OMP_END_TARGET_PARALLEL_DO
:
2200 p
= "!$OMP END TARGET PARALLEL DO";
2202 case ST_OMP_END_TARGET_PARALLEL_DO_SIMD
:
2203 p
= "!$OMP END TARGET PARALLEL DO SIMD";
2205 case ST_OMP_END_TARGET_SIMD
:
2206 p
= "!$OMP END TARGET SIMD";
2208 case ST_OMP_END_TARGET_TEAMS
:
2209 p
= "!$OMP END TARGET TEAMS";
2211 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
:
2212 p
= "!$OMP END TARGET TEAMS DISTRIBUTE";
2214 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2215 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2217 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2218 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2220 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2221 p
= "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2223 case ST_OMP_END_TASKGROUP
:
2224 p
= "!$OMP END TASKGROUP";
2226 case ST_OMP_END_TASKLOOP
:
2227 p
= "!$OMP END TASKLOOP";
2229 case ST_OMP_END_TASKLOOP_SIMD
:
2230 p
= "!$OMP END TASKLOOP SIMD";
2232 case ST_OMP_END_TEAMS
:
2233 p
= "!$OMP END TEAMS";
2235 case ST_OMP_END_TEAMS_DISTRIBUTE
:
2236 p
= "!$OMP END TEAMS DISTRIBUTE";
2238 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2239 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2241 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2242 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2244 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
:
2245 p
= "!$OMP END TEAMS DISTRIBUTE SIMD";
2247 case ST_OMP_END_WORKSHARE
:
2248 p
= "!$OMP END WORKSHARE";
2256 case ST_OMP_ORDERED
:
2257 case ST_OMP_ORDERED_DEPEND
:
2258 p
= "!$OMP ORDERED";
2260 case ST_OMP_PARALLEL
:
2261 p
= "!$OMP PARALLEL";
2263 case ST_OMP_PARALLEL_DO
:
2264 p
= "!$OMP PARALLEL DO";
2266 case ST_OMP_PARALLEL_DO_SIMD
:
2267 p
= "!$OMP PARALLEL DO SIMD";
2269 case ST_OMP_PARALLEL_SECTIONS
:
2270 p
= "!$OMP PARALLEL SECTIONS";
2272 case ST_OMP_PARALLEL_WORKSHARE
:
2273 p
= "!$OMP PARALLEL WORKSHARE";
2275 case ST_OMP_SECTIONS
:
2276 p
= "!$OMP SECTIONS";
2278 case ST_OMP_SECTION
:
2279 p
= "!$OMP SECTION";
2290 case ST_OMP_TARGET_DATA
:
2291 p
= "!$OMP TARGET DATA";
2293 case ST_OMP_TARGET_ENTER_DATA
:
2294 p
= "!$OMP TARGET ENTER DATA";
2296 case ST_OMP_TARGET_EXIT_DATA
:
2297 p
= "!$OMP TARGET EXIT DATA";
2299 case ST_OMP_TARGET_PARALLEL
:
2300 p
= "!$OMP TARGET PARALLEL";
2302 case ST_OMP_TARGET_PARALLEL_DO
:
2303 p
= "!$OMP TARGET PARALLEL DO";
2305 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
2306 p
= "!$OMP TARGET PARALLEL DO SIMD";
2308 case ST_OMP_TARGET_SIMD
:
2309 p
= "!$OMP TARGET SIMD";
2311 case ST_OMP_TARGET_TEAMS
:
2312 p
= "!$OMP TARGET TEAMS";
2314 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
2315 p
= "!$OMP TARGET TEAMS DISTRIBUTE";
2317 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2318 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2320 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2321 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2323 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2324 p
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2326 case ST_OMP_TARGET_UPDATE
:
2327 p
= "!$OMP TARGET UPDATE";
2332 case ST_OMP_TASKGROUP
:
2333 p
= "!$OMP TASKGROUP";
2335 case ST_OMP_TASKLOOP
:
2336 p
= "!$OMP TASKLOOP";
2338 case ST_OMP_TASKLOOP_SIMD
:
2339 p
= "!$OMP TASKLOOP SIMD";
2341 case ST_OMP_TASKWAIT
:
2342 p
= "!$OMP TASKWAIT";
2344 case ST_OMP_TASKYIELD
:
2345 p
= "!$OMP TASKYIELD";
2350 case ST_OMP_TEAMS_DISTRIBUTE
:
2351 p
= "!$OMP TEAMS DISTRIBUTE";
2353 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2354 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2356 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2357 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2359 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
2360 p
= "!$OMP TEAMS DISTRIBUTE SIMD";
2362 case ST_OMP_THREADPRIVATE
:
2363 p
= "!$OMP THREADPRIVATE";
2365 case ST_OMP_WORKSHARE
:
2366 p
= "!$OMP WORKSHARE";
2369 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2376 /* Create a symbol for the main program and assign it to ns->proc_name. */
2379 main_program_symbol (gfc_namespace
*ns
, const char *name
)
2381 gfc_symbol
*main_program
;
2382 symbol_attribute attr
;
2384 gfc_get_symbol (name
, ns
, &main_program
);
2385 gfc_clear_attr (&attr
);
2386 attr
.flavor
= FL_PROGRAM
;
2387 attr
.proc
= PROC_UNKNOWN
;
2388 attr
.subroutine
= 1;
2389 attr
.access
= ACCESS_PUBLIC
;
2390 attr
.is_main_program
= 1;
2391 main_program
->attr
= attr
;
2392 main_program
->declared_at
= gfc_current_locus
;
2393 ns
->proc_name
= main_program
;
2394 gfc_commit_symbols ();
2398 /* Do whatever is necessary to accept the last statement. */
2401 accept_statement (gfc_statement st
)
2405 case ST_IMPLICIT_NONE
:
2413 gfc_current_ns
->proc_name
= gfc_new_block
;
2416 /* If the statement is the end of a block, lay down a special code
2417 that allows a branch to the end of the block from within the
2418 construct. IF and SELECT are treated differently from DO
2419 (where EXEC_NOP is added inside the loop) for two
2421 1. END DO has a meaning in the sense that after a GOTO to
2422 it, the loop counter must be increased.
2423 2. IF blocks and SELECT blocks can consist of multiple
2424 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
2425 Putting the label before the END IF would make the jump
2426 from, say, the ELSE IF block to the END IF illegal. */
2430 case ST_END_CRITICAL
:
2431 if (gfc_statement_label
!= NULL
)
2433 new_st
.op
= EXEC_END_NESTED_BLOCK
;
2438 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
2439 one parallel block. Thus, we add the special code to the nested block
2440 itself, instead of the parent one. */
2442 case ST_END_ASSOCIATE
:
2443 if (gfc_statement_label
!= NULL
)
2445 new_st
.op
= EXEC_END_BLOCK
;
2450 /* The end-of-program unit statements do not get the special
2451 marker and require a statement of some sort if they are a
2454 case ST_END_PROGRAM
:
2455 case ST_END_FUNCTION
:
2456 case ST_END_SUBROUTINE
:
2457 if (gfc_statement_label
!= NULL
)
2459 new_st
.op
= EXEC_RETURN
;
2464 new_st
.op
= EXEC_END_PROCEDURE
;
2480 gfc_commit_symbols ();
2481 gfc_warning_check ();
2482 gfc_clear_new_st ();
2486 /* Clear default character types with charlen pointers that are about
2487 to become invalid. */
2490 clear_default_charlen (gfc_namespace
*ns
, const gfc_charlen
*cl
,
2491 const gfc_charlen
*end
)
2495 for (ts
= &ns
->default_type
[0]; ts
< &ns
->default_type
[GFC_LETTERS
]; ts
++)
2496 if (ts
->type
== BT_CHARACTER
)
2498 const gfc_charlen
*cl2
;
2499 for (cl2
= cl
; cl2
!= end
; cl2
= cl2
->next
)
2500 if (ts
->u
.cl
== cl2
)
2503 ts
->type
= BT_UNKNOWN
;
2509 /* Undo anything tentative that has been built for the current
2513 reject_statement (void)
2515 /* Revert to the previous charlen chain. */
2516 clear_default_charlen (gfc_current_ns
,
2517 gfc_current_ns
->cl_list
, gfc_current_ns
->old_cl_list
);
2518 gfc_free_charlen (gfc_current_ns
->cl_list
, gfc_current_ns
->old_cl_list
);
2519 gfc_current_ns
->cl_list
= gfc_current_ns
->old_cl_list
;
2521 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
2522 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
2524 gfc_reject_data (gfc_current_ns
);
2526 gfc_new_block
= NULL
;
2527 gfc_undo_symbols ();
2528 gfc_clear_warning ();
2529 undo_new_statement ();
2533 /* Generic complaint about an out of order statement. We also do
2534 whatever is necessary to clean up. */
2537 unexpected_statement (gfc_statement st
)
2539 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
2541 reject_statement ();
2545 /* Given the next statement seen by the matcher, make sure that it is
2546 in proper order with the last. This subroutine is initialized by
2547 calling it with an argument of ST_NONE. If there is a problem, we
2548 issue an error and return false. Otherwise we return true.
2550 Individual parsers need to verify that the statements seen are
2551 valid before calling here, i.e., ENTRY statements are not allowed in
2552 INTERFACE blocks. The following diagram is taken from the standard:
2554 +---------------------------------------+
2555 | program subroutine function module |
2556 +---------------------------------------+
2558 +---------------------------------------+
2560 +---------------------------------------+
2562 | +-----------+------------------+
2563 | | parameter | implicit |
2564 | +-----------+------------------+
2565 | format | | derived type |
2566 | entry | parameter | interface |
2567 | | data | specification |
2568 | | | statement func |
2569 | +-----------+------------------+
2570 | | data | executable |
2571 +--------+-----------+------------------+
2573 +---------------------------------------+
2574 | internal module/subprogram |
2575 +---------------------------------------+
2577 +---------------------------------------+
2586 ORDER_IMPLICIT_NONE
,
2594 enum state_order state
;
2595 gfc_statement last_statement
;
2601 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
2607 p
->state
= ORDER_START
;
2611 if (p
->state
> ORDER_USE
)
2613 p
->state
= ORDER_USE
;
2617 if (p
->state
> ORDER_IMPORT
)
2619 p
->state
= ORDER_IMPORT
;
2622 case ST_IMPLICIT_NONE
:
2623 if (p
->state
> ORDER_IMPLICIT
)
2626 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2627 statement disqualifies a USE but not an IMPLICIT NONE.
2628 Duplicate IMPLICIT NONEs are caught when the implicit types
2631 p
->state
= ORDER_IMPLICIT_NONE
;
2635 if (p
->state
> ORDER_IMPLICIT
)
2637 p
->state
= ORDER_IMPLICIT
;
2642 if (p
->state
< ORDER_IMPLICIT_NONE
)
2643 p
->state
= ORDER_IMPLICIT_NONE
;
2647 if (p
->state
>= ORDER_EXEC
)
2649 if (p
->state
< ORDER_IMPLICIT
)
2650 p
->state
= ORDER_IMPLICIT
;
2654 if (p
->state
< ORDER_SPEC
)
2655 p
->state
= ORDER_SPEC
;
2660 case ST_STRUCTURE_DECL
:
2661 case ST_DERIVED_DECL
:
2663 if (p
->state
>= ORDER_EXEC
)
2665 if (p
->state
< ORDER_SPEC
)
2666 p
->state
= ORDER_SPEC
;
2670 /* The OpenMP directives have to be somewhere in the specification
2671 part, but there are no further requirements on their ordering.
2672 Thus don't adjust p->state, just ignore them. */
2673 if (p
->state
>= ORDER_EXEC
)
2679 if (p
->state
< ORDER_EXEC
)
2680 p
->state
= ORDER_EXEC
;
2687 /* All is well, record the statement in case we need it next time. */
2688 p
->where
= gfc_current_locus
;
2689 p
->last_statement
= st
;
2694 gfc_error ("%s statement at %C cannot follow %s statement at %L",
2695 gfc_ascii_statement (st
),
2696 gfc_ascii_statement (p
->last_statement
), &p
->where
);
2702 /* Handle an unexpected end of file. This is a show-stopper... */
2704 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
2707 unexpected_eof (void)
2711 gfc_error ("Unexpected end of file in %qs", gfc_source_file
);
2713 /* Memory cleanup. Move to "second to last". */
2714 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
2717 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
2720 longjmp (eof_buf
, 1);
2724 /* Parse the CONTAINS section of a derived type definition. */
2726 gfc_access gfc_typebound_default_access
;
2729 parse_derived_contains (void)
2732 bool seen_private
= false;
2733 bool seen_comps
= false;
2734 bool error_flag
= false;
2737 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2738 gcc_assert (gfc_current_block ());
2740 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
2742 if (gfc_current_block ()->attr
.sequence
)
2743 gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
2744 " section at %C", gfc_current_block ()->name
);
2745 if (gfc_current_block ()->attr
.is_bind_c
)
2746 gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
2747 " section at %C", gfc_current_block ()->name
);
2749 accept_statement (ST_CONTAINS
);
2750 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
2752 gfc_typebound_default_access
= ACCESS_PUBLIC
;
2758 st
= next_statement ();
2766 gfc_error ("Components in TYPE at %C must precede CONTAINS");
2770 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
2773 accept_statement (ST_PROCEDURE
);
2778 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
2781 accept_statement (ST_GENERIC
);
2786 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
2790 accept_statement (ST_FINAL
);
2798 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
2799 "at %C with empty CONTAINS section")))
2802 /* ST_END_TYPE is accepted by parse_derived after return. */
2806 if (!gfc_find_state (COMP_MODULE
))
2808 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2815 gfc_error ("PRIVATE statement at %C must precede procedure"
2822 gfc_error ("Duplicate PRIVATE statement at %C");
2826 accept_statement (ST_PRIVATE
);
2827 gfc_typebound_default_access
= ACCESS_PRIVATE
;
2828 seen_private
= true;
2832 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2836 gfc_error ("Already inside a CONTAINS block at %C");
2840 unexpected_statement (st
);
2848 reject_statement ();
2852 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2858 /* Set attributes for the parent symbol based on the attributes of a component
2859 and raise errors if conflicting attributes are found for the component. */
2862 check_component (gfc_symbol
*sym
, gfc_component
*c
, gfc_component
**lockp
,
2863 gfc_component
**eventp
)
2865 bool coarray
, lock_type
, event_type
, allocatable
, pointer
;
2866 coarray
= lock_type
= event_type
= allocatable
= pointer
= false;
2867 gfc_component
*lock_comp
= NULL
, *event_comp
= NULL
;
2869 if (lockp
) lock_comp
= *lockp
;
2870 if (eventp
) event_comp
= *eventp
;
2872 /* Look for allocatable components. */
2873 if (c
->attr
.allocatable
2874 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2875 && CLASS_DATA (c
)->attr
.allocatable
)
2876 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
2877 && c
->ts
.u
.derived
->attr
.alloc_comp
))
2880 sym
->attr
.alloc_comp
= 1;
2883 /* Look for pointer components. */
2885 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2886 && CLASS_DATA (c
)->attr
.class_pointer
)
2887 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
2890 sym
->attr
.pointer_comp
= 1;
2893 /* Look for procedure pointer components. */
2894 if (c
->attr
.proc_pointer
2895 || (c
->ts
.type
== BT_DERIVED
2896 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
2897 sym
->attr
.proc_pointer_comp
= 1;
2899 /* Looking for coarray components. */
2900 if (c
->attr
.codimension
2901 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2902 && CLASS_DATA (c
)->attr
.codimension
))
2905 sym
->attr
.coarray_comp
= 1;
2908 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
2909 && !c
->attr
.pointer
)
2912 sym
->attr
.coarray_comp
= 1;
2915 /* Looking for lock_type components. */
2916 if ((c
->ts
.type
== BT_DERIVED
2917 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2918 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2919 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2920 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2921 == INTMOD_ISO_FORTRAN_ENV
2922 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2923 == ISOFORTRAN_LOCK_TYPE
)
2924 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
2925 && !allocatable
&& !pointer
))
2929 sym
->attr
.lock_comp
= 1;
2932 /* Looking for event_type components. */
2933 if ((c
->ts
.type
== BT_DERIVED
2934 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2935 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2936 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2937 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2938 == INTMOD_ISO_FORTRAN_ENV
2939 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2940 == ISOFORTRAN_EVENT_TYPE
)
2941 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.event_comp
2942 && !allocatable
&& !pointer
))
2946 sym
->attr
.event_comp
= 1;
2949 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2950 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2951 unless there are nondirect [allocatable or pointer] components
2952 involved (cf. 1.3.33.1 and 1.3.33.3). */
2954 if (pointer
&& !coarray
&& lock_type
)
2955 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2956 "codimension or be a subcomponent of a coarray, "
2957 "which is not possible as the component has the "
2958 "pointer attribute", c
->name
, &c
->loc
);
2959 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
2960 && c
->ts
.u
.derived
->attr
.lock_comp
)
2961 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2962 "of type LOCK_TYPE, which must have a codimension or be a "
2963 "subcomponent of a coarray", c
->name
, &c
->loc
);
2965 if (lock_type
&& allocatable
&& !coarray
)
2966 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
2967 "a codimension", c
->name
, &c
->loc
);
2968 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
2969 && c
->ts
.u
.derived
->attr
.lock_comp
)
2970 gfc_error ("Allocatable component %s at %L must have a codimension as "
2971 "it has a noncoarray subcomponent of type LOCK_TYPE",
2974 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
2975 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2976 "subcomponent of type LOCK_TYPE must have a codimension or "
2977 "be a subcomponent of a coarray. (Variables of type %s may "
2978 "not have a codimension as already a coarray "
2979 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
2981 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
2982 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2983 "subcomponent of type LOCK_TYPE must have a codimension or "
2984 "be a subcomponent of a coarray. (Variables of type %s may "
2985 "not have a codimension as %s at %L has a codimension or a "
2986 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
2987 sym
->name
, c
->name
, &c
->loc
);
2989 /* Similarly for EVENT TYPE. */
2991 if (pointer
&& !coarray
&& event_type
)
2992 gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
2993 "codimension or be a subcomponent of a coarray, "
2994 "which is not possible as the component has the "
2995 "pointer attribute", c
->name
, &c
->loc
);
2996 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
2997 && c
->ts
.u
.derived
->attr
.event_comp
)
2998 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2999 "of type EVENT_TYPE, which must have a codimension or be a "
3000 "subcomponent of a coarray", c
->name
, &c
->loc
);
3002 if (event_type
&& allocatable
&& !coarray
)
3003 gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
3004 "a codimension", c
->name
, &c
->loc
);
3005 else if (event_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
3006 && c
->ts
.u
.derived
->attr
.event_comp
)
3007 gfc_error ("Allocatable component %s at %L must have a codimension as "
3008 "it has a noncoarray subcomponent of type EVENT_TYPE",
3011 if (sym
->attr
.coarray_comp
&& !coarray
&& event_type
)
3012 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3013 "subcomponent of type EVENT_TYPE must have a codimension or "
3014 "be a subcomponent of a coarray. (Variables of type %s may "
3015 "not have a codimension as already a coarray "
3016 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
3018 if (sym
->attr
.event_comp
&& coarray
&& !event_type
)
3019 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3020 "subcomponent of type EVENT_TYPE must have a codimension or "
3021 "be a subcomponent of a coarray. (Variables of type %s may "
3022 "not have a codimension as %s at %L has a codimension or a "
3023 "coarray subcomponent)", event_comp
->name
, &event_comp
->loc
,
3024 sym
->name
, c
->name
, &c
->loc
);
3026 /* Look for private components. */
3027 if (sym
->component_access
== ACCESS_PRIVATE
3028 || c
->attr
.access
== ACCESS_PRIVATE
3029 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
3030 sym
->attr
.private_comp
= 1;
3032 if (lockp
) *lockp
= lock_comp
;
3033 if (eventp
) *eventp
= event_comp
;
3037 static void parse_struct_map (gfc_statement
);
3039 /* Parse a union component definition within a structure definition. */
3047 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3050 accept_statement(ST_UNION
);
3051 push_state (&s
, COMP_UNION
, gfc_new_block
);
3058 st
= next_statement ();
3059 /* Only MAP declarations valid within a union. */
3066 accept_statement (ST_MAP
);
3067 parse_struct_map (ST_MAP
);
3068 /* Add a component to the union for each map. */
3069 if (!gfc_add_component (un
, gfc_new_block
->name
, &c
))
3071 gfc_internal_error ("failed to create map component '%s'",
3072 gfc_new_block
->name
);
3073 reject_statement ();
3076 c
->ts
.type
= BT_DERIVED
;
3077 c
->ts
.u
.derived
= gfc_new_block
;
3078 /* Normally components get their initialization expressions when they
3079 are created in decl.c (build_struct) so we can look through the
3080 flat component list for initializers during resolution. Unions and
3081 maps create components along with their type definitions so we
3082 have to generate initializers here. */
3083 c
->initializer
= gfc_default_initializer (&c
->ts
);
3088 accept_statement (ST_END_UNION
);
3092 unexpected_statement (st
);
3097 for (c
= un
->components
; c
; c
= c
->next
)
3098 check_component (un
, c
, &lock_comp
, &event_comp
);
3100 /* Add the union as a component in its parent structure. */
3102 if (!gfc_add_component (gfc_current_block (), un
->name
, &c
))
3104 gfc_internal_error ("failed to create union component '%s'", un
->name
);
3105 reject_statement ();
3108 c
->ts
.type
= BT_UNION
;
3109 c
->ts
.u
.derived
= un
;
3110 c
->initializer
= gfc_default_initializer (&c
->ts
);
3112 un
->attr
.zero_comp
= un
->components
== NULL
;
3116 /* Parse a STRUCTURE or MAP. */
3119 parse_struct_map (gfc_statement block
)
3125 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3126 gfc_compile_state comp
;
3129 if (block
== ST_STRUCTURE_DECL
)
3131 comp
= COMP_STRUCTURE
;
3132 ends
= ST_END_STRUCTURE
;
3136 gcc_assert (block
== ST_MAP
);
3141 accept_statement(block
);
3142 push_state (&s
, comp
, gfc_new_block
);
3144 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3147 while (compiling_type
)
3149 st
= next_statement ();
3155 /* Nested structure declarations will be captured as ST_DATA_DECL. */
3156 case ST_STRUCTURE_DECL
:
3157 /* Let a more specific error make it to decode_statement(). */
3158 if (gfc_error_check () == 0)
3159 gfc_error ("Syntax error in nested structure declaration at %C");
3160 reject_statement ();
3161 /* Skip the rest of this statement. */
3162 gfc_error_recovery ();
3166 accept_statement (ST_UNION
);
3171 /* The data declaration was a nested/ad-hoc STRUCTURE field. */
3172 accept_statement (ST_DATA_DECL
);
3173 if (gfc_new_block
&& gfc_new_block
!= gfc_current_block ()
3174 && gfc_new_block
->attr
.flavor
== FL_STRUCT
)
3175 parse_struct_map (ST_STRUCTURE_DECL
);
3178 case ST_END_STRUCTURE
:
3182 accept_statement (st
);
3186 unexpected_statement (st
);
3190 unexpected_statement (st
);
3195 /* Validate each component. */
3196 sym
= gfc_current_block ();
3197 for (c
= sym
->components
; c
; c
= c
->next
)
3198 check_component (sym
, c
, &lock_comp
, &event_comp
);
3200 sym
->attr
.zero_comp
= (sym
->components
== NULL
);
3202 /* Allow parse_union to find this structure to add to its list of maps. */
3203 if (block
== ST_MAP
)
3204 gfc_new_block
= gfc_current_block ();
3210 /* Parse a derived type. */
3213 parse_derived (void)
3215 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
3219 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3221 accept_statement (ST_DERIVED_DECL
);
3222 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
3224 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3231 while (compiling_type
)
3233 st
= next_statement ();
3241 accept_statement (st
);
3246 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
3253 if (!seen_component
)
3254 gfc_notify_std (GFC_STD_F2003
, "Derived type "
3255 "definition at %C without components");
3257 accept_statement (ST_END_TYPE
);
3261 if (!gfc_find_state (COMP_MODULE
))
3263 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3270 gfc_error ("PRIVATE statement at %C must precede "
3271 "structure components");
3276 gfc_error ("Duplicate PRIVATE statement at %C");
3278 s
.sym
->component_access
= ACCESS_PRIVATE
;
3280 accept_statement (ST_PRIVATE
);
3287 gfc_error ("SEQUENCE statement at %C must precede "
3288 "structure components");
3292 if (gfc_current_block ()->attr
.sequence
)
3293 gfc_warning (0, "SEQUENCE attribute at %C already specified in "
3298 gfc_error ("Duplicate SEQUENCE statement at %C");
3302 gfc_add_sequence (&gfc_current_block ()->attr
,
3303 gfc_current_block ()->name
, NULL
);
3307 gfc_notify_std (GFC_STD_F2003
,
3308 "CONTAINS block in derived type"
3309 " definition at %C");
3311 accept_statement (ST_CONTAINS
);
3312 parse_derived_contains ();
3316 unexpected_statement (st
);
3321 /* need to verify that all fields of the derived type are
3322 * interoperable with C if the type is declared to be bind(c)
3324 sym
= gfc_current_block ();
3325 for (c
= sym
->components
; c
; c
= c
->next
)
3326 check_component (sym
, c
, &lock_comp
, &event_comp
);
3328 if (!seen_component
)
3329 sym
->attr
.zero_comp
= 1;
3335 /* Parse an ENUM. */
3343 int seen_enumerator
= 0;
3345 push_state (&s
, COMP_ENUM
, gfc_new_block
);
3349 while (compiling_enum
)
3351 st
= next_statement ();
3359 seen_enumerator
= 1;
3360 accept_statement (st
);
3365 if (!seen_enumerator
)
3366 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
3367 accept_statement (st
);
3371 gfc_free_enum_history ();
3372 unexpected_statement (st
);
3380 /* Parse an interface. We must be able to deal with the possibility
3381 of recursive interfaces. The parse_spec() subroutine is mutually
3382 recursive with parse_interface(). */
3384 static gfc_statement
parse_spec (gfc_statement
);
3387 parse_interface (void)
3389 gfc_compile_state new_state
= COMP_NONE
, current_state
;
3390 gfc_symbol
*prog_unit
, *sym
;
3391 gfc_interface_info save
;
3392 gfc_state_data s1
, s2
;
3395 accept_statement (ST_INTERFACE
);
3397 current_interface
.ns
= gfc_current_ns
;
3398 save
= current_interface
;
3400 sym
= (current_interface
.type
== INTERFACE_GENERIC
3401 || current_interface
.type
== INTERFACE_USER_OP
)
3402 ? gfc_new_block
: NULL
;
3404 push_state (&s1
, COMP_INTERFACE
, sym
);
3405 current_state
= COMP_NONE
;
3408 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
3410 st
= next_statement ();
3418 if (st
== ST_SUBROUTINE
)
3419 new_state
= COMP_SUBROUTINE
;
3420 else if (st
== ST_FUNCTION
)
3421 new_state
= COMP_FUNCTION
;
3422 if (gfc_new_block
->attr
.pointer
)
3424 gfc_new_block
->attr
.pointer
= 0;
3425 gfc_new_block
->attr
.proc_pointer
= 1;
3427 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
3428 gfc_new_block
->formal
, NULL
))
3430 reject_statement ();
3431 gfc_free_namespace (gfc_current_ns
);
3434 /* F2008 C1210 forbids the IMPORT statement in module procedure
3435 interface bodies and the flag is set to import symbols. */
3436 if (gfc_new_block
->attr
.module_procedure
)
3437 gfc_current_ns
->has_import_set
= 1;
3441 case ST_MODULE_PROC
: /* The module procedure matcher makes
3442 sure the context is correct. */
3443 accept_statement (st
);
3444 gfc_free_namespace (gfc_current_ns
);
3447 case ST_END_INTERFACE
:
3448 gfc_free_namespace (gfc_current_ns
);
3449 gfc_current_ns
= current_interface
.ns
;
3453 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
3454 gfc_ascii_statement (st
));
3455 reject_statement ();
3456 gfc_free_namespace (gfc_current_ns
);
3461 /* Make sure that the generic name has the right attribute. */
3462 if (current_interface
.type
== INTERFACE_GENERIC
3463 && current_state
== COMP_NONE
)
3465 if (new_state
== COMP_FUNCTION
&& sym
)
3466 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
3467 else if (new_state
== COMP_SUBROUTINE
&& sym
)
3468 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
3470 current_state
= new_state
;
3473 if (current_interface
.type
== INTERFACE_ABSTRACT
)
3475 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
3476 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
3477 gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
3478 "cannot be the same as an intrinsic type",
3479 gfc_new_block
->name
);
3482 push_state (&s2
, new_state
, gfc_new_block
);
3483 accept_statement (st
);
3484 prog_unit
= gfc_new_block
;
3485 prog_unit
->formal_ns
= gfc_current_ns
;
3486 if (prog_unit
== prog_unit
->formal_ns
->proc_name
3487 && prog_unit
->ns
!= prog_unit
->formal_ns
)
3491 /* Read data declaration statements. */
3492 st
= parse_spec (ST_NONE
);
3493 in_specification_block
= true;
3495 /* Since the interface block does not permit an IMPLICIT statement,
3496 the default type for the function or the result must be taken
3497 from the formal namespace. */
3498 if (new_state
== COMP_FUNCTION
)
3500 if (prog_unit
->result
== prog_unit
3501 && prog_unit
->ts
.type
== BT_UNKNOWN
)
3502 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
3503 else if (prog_unit
->result
!= prog_unit
3504 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
3505 gfc_set_default_type (prog_unit
->result
, 1,
3506 prog_unit
->formal_ns
);
3509 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
3511 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
3512 gfc_ascii_statement (st
));
3513 reject_statement ();
3517 /* Add EXTERNAL attribute to function or subroutine. */
3518 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
3519 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
3521 current_interface
= save
;
3522 gfc_add_interface (prog_unit
);
3525 if (current_interface
.ns
3526 && current_interface
.ns
->proc_name
3527 && strcmp (current_interface
.ns
->proc_name
->name
,
3528 prog_unit
->name
) == 0)
3529 gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
3530 "enclosing procedure", prog_unit
->name
,
3531 ¤t_interface
.ns
->proc_name
->declared_at
);
3540 /* Associate function characteristics by going back to the function
3541 declaration and rematching the prefix. */
3544 match_deferred_characteristics (gfc_typespec
* ts
)
3547 match m
= MATCH_ERROR
;
3548 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3550 loc
= gfc_current_locus
;
3552 gfc_current_locus
= gfc_current_block ()->declared_at
;
3555 gfc_buffer_error (true);
3556 m
= gfc_match_prefix (ts
);
3557 gfc_buffer_error (false);
3559 if (ts
->type
== BT_DERIVED
)
3567 /* Only permit one go at the characteristic association. */
3571 /* Set the function locus correctly. If we have not found the
3572 function name, there is an error. */
3574 && gfc_match ("function% %n", name
) == MATCH_YES
3575 && strcmp (name
, gfc_current_block ()->name
) == 0)
3577 gfc_current_block ()->declared_at
= gfc_current_locus
;
3578 gfc_commit_symbols ();
3583 gfc_undo_symbols ();
3586 gfc_current_locus
=loc
;
3591 /* Check specification-expressions in the function result of the currently
3592 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
3593 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
3594 scope are not yet parsed so this has to be delayed up to parse_spec. */
3597 check_function_result_typed (void)
3601 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
3603 if (!gfc_current_ns
->proc_name
->result
) return;
3605 ts
= gfc_current_ns
->proc_name
->result
->ts
;
3607 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
3608 /* TODO: Extend when KIND type parameters are implemented. */
3609 if (ts
.type
== BT_CHARACTER
&& ts
.u
.cl
&& ts
.u
.cl
->length
)
3610 gfc_expr_check_typed (ts
.u
.cl
->length
, gfc_current_ns
, true);
3614 /* Parse a set of specification statements. Returns the statement
3615 that doesn't fit. */
3617 static gfc_statement
3618 parse_spec (gfc_statement st
)
3621 bool function_result_typed
= false;
3622 bool bad_characteristic
= false;
3625 in_specification_block
= true;
3627 verify_st_order (&ss
, ST_NONE
, false);
3629 st
= next_statement ();
3631 /* If we are not inside a function or don't have a result specified so far,
3632 do nothing special about it. */
3633 if (gfc_current_state () != COMP_FUNCTION
)
3634 function_result_typed
= true;
3637 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
3640 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
3641 function_result_typed
= true;
3646 /* If we're inside a BLOCK construct, some statements are disallowed.
3647 Check this here. Attribute declaration statements like INTENT, OPTIONAL
3648 or VALUE are also disallowed, but they don't have a particular ST_*
3649 key so we have to check for them individually in their matcher routine. */
3650 if (gfc_current_state () == COMP_BLOCK
)
3654 case ST_IMPLICIT_NONE
:
3657 case ST_EQUIVALENCE
:
3658 case ST_STATEMENT_FUNCTION
:
3659 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
3660 gfc_ascii_statement (st
));
3661 reject_statement ();
3667 else if (gfc_current_state () == COMP_BLOCK_DATA
)
3668 /* Fortran 2008, C1116. */
3675 case ST_DERIVED_DECL
:
3676 case ST_END_BLOCK_DATA
:
3677 case ST_EQUIVALENCE
:
3679 case ST_IMPLICIT_NONE
:
3681 case ST_STRUCTURE_DECL
:
3690 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
3691 gfc_ascii_statement (st
));
3692 reject_statement ();
3696 /* If we find a statement that can not be followed by an IMPLICIT statement
3697 (and thus we can expect to see none any further), type the function result
3698 if it has not yet been typed. Be careful not to give the END statement
3699 to verify_st_order! */
3700 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
3702 bool verify_now
= false;
3704 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
3709 verify_st_order (&dummyss
, ST_NONE
, false);
3710 verify_st_order (&dummyss
, st
, false);
3712 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
3718 check_function_result_typed ();
3719 function_result_typed
= true;
3728 case ST_IMPLICIT_NONE
:
3730 if (!function_result_typed
)
3732 check_function_result_typed ();
3733 function_result_typed
= true;
3739 case ST_DATA
: /* Not allowed in interfaces */
3740 if (gfc_current_state () == COMP_INTERFACE
)
3750 case ST_STRUCTURE_DECL
:
3751 case ST_DERIVED_DECL
:
3755 if (!verify_st_order (&ss
, st
, false))
3757 reject_statement ();
3758 st
= next_statement ();
3768 case ST_STRUCTURE_DECL
:
3769 parse_struct_map (ST_STRUCTURE_DECL
);
3772 case ST_DERIVED_DECL
:
3778 if (gfc_current_state () != COMP_MODULE
)
3780 gfc_error ("%s statement must appear in a MODULE",
3781 gfc_ascii_statement (st
));
3782 reject_statement ();
3786 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
3788 gfc_error ("%s statement at %C follows another accessibility "
3789 "specification", gfc_ascii_statement (st
));
3790 reject_statement ();
3794 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
3795 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3799 case ST_STATEMENT_FUNCTION
:
3800 if (gfc_current_state () == COMP_MODULE
3801 || gfc_current_state () == COMP_SUBMODULE
)
3803 unexpected_statement (st
);
3811 accept_statement (st
);
3812 st
= next_statement ();
3816 accept_statement (st
);
3818 st
= next_statement ();
3821 case ST_GET_FCN_CHARACTERISTICS
:
3822 /* This statement triggers the association of a function's result
3824 ts
= &gfc_current_block ()->result
->ts
;
3825 if (match_deferred_characteristics (ts
) != MATCH_YES
)
3826 bad_characteristic
= true;
3828 st
= next_statement ();
3835 /* If match_deferred_characteristics failed, then there is an error. */
3836 if (bad_characteristic
)
3838 ts
= &gfc_current_block ()->result
->ts
;
3839 if (ts
->type
!= BT_DERIVED
)
3840 gfc_error ("Bad kind expression for function %qs at %L",
3841 gfc_current_block ()->name
,
3842 &gfc_current_block ()->declared_at
);
3844 gfc_error ("The type for function %qs at %L is not accessible",
3845 gfc_current_block ()->name
,
3846 &gfc_current_block ()->declared_at
);
3848 gfc_current_block ()->ts
.kind
= 0;
3849 /* Keep the derived type; if it's bad, it will be discovered later. */
3850 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
3851 ts
->type
= BT_UNKNOWN
;
3854 in_specification_block
= false;
3860 /* Parse a WHERE block, (not a simple WHERE statement). */
3863 parse_where_block (void)
3865 int seen_empty_else
;
3870 accept_statement (ST_WHERE_BLOCK
);
3871 top
= gfc_state_stack
->tail
;
3873 push_state (&s
, COMP_WHERE
, gfc_new_block
);
3875 d
= add_statement ();
3876 d
->expr1
= top
->expr1
;
3882 seen_empty_else
= 0;
3886 st
= next_statement ();
3892 case ST_WHERE_BLOCK
:
3893 parse_where_block ();
3898 accept_statement (st
);
3902 if (seen_empty_else
)
3904 gfc_error ("ELSEWHERE statement at %C follows previous "
3905 "unmasked ELSEWHERE");
3906 reject_statement ();
3910 if (new_st
.expr1
== NULL
)
3911 seen_empty_else
= 1;
3913 d
= new_level (gfc_state_stack
->head
);
3915 d
->expr1
= new_st
.expr1
;
3917 accept_statement (st
);
3922 accept_statement (st
);
3926 gfc_error ("Unexpected %s statement in WHERE block at %C",
3927 gfc_ascii_statement (st
));
3928 reject_statement ();
3932 while (st
!= ST_END_WHERE
);
3938 /* Parse a FORALL block (not a simple FORALL statement). */
3941 parse_forall_block (void)
3947 accept_statement (ST_FORALL_BLOCK
);
3948 top
= gfc_state_stack
->tail
;
3950 push_state (&s
, COMP_FORALL
, gfc_new_block
);
3952 d
= add_statement ();
3953 d
->op
= EXEC_FORALL
;
3958 st
= next_statement ();
3963 case ST_POINTER_ASSIGNMENT
:
3966 accept_statement (st
);
3969 case ST_WHERE_BLOCK
:
3970 parse_where_block ();
3973 case ST_FORALL_BLOCK
:
3974 parse_forall_block ();
3978 accept_statement (st
);
3985 gfc_error ("Unexpected %s statement in FORALL block at %C",
3986 gfc_ascii_statement (st
));
3988 reject_statement ();
3992 while (st
!= ST_END_FORALL
);
3998 static gfc_statement
parse_executable (gfc_statement
);
4000 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
4003 parse_if_block (void)
4012 accept_statement (ST_IF_BLOCK
);
4014 top
= gfc_state_stack
->tail
;
4015 push_state (&s
, COMP_IF
, gfc_new_block
);
4017 new_st
.op
= EXEC_IF
;
4018 d
= add_statement ();
4020 d
->expr1
= top
->expr1
;
4026 st
= parse_executable (ST_NONE
);
4036 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
4037 "statement at %L", &else_locus
);
4039 reject_statement ();
4043 d
= new_level (gfc_state_stack
->head
);
4045 d
->expr1
= new_st
.expr1
;
4047 accept_statement (st
);
4054 gfc_error ("Duplicate ELSE statements at %L and %C",
4056 reject_statement ();
4061 else_locus
= gfc_current_locus
;
4063 d
= new_level (gfc_state_stack
->head
);
4066 accept_statement (st
);
4074 unexpected_statement (st
);
4078 while (st
!= ST_ENDIF
);
4081 accept_statement (st
);
4085 /* Parse a SELECT block. */
4088 parse_select_block (void)
4094 accept_statement (ST_SELECT_CASE
);
4096 cp
= gfc_state_stack
->tail
;
4097 push_state (&s
, COMP_SELECT
, gfc_new_block
);
4099 /* Make sure that the next statement is a CASE or END SELECT. */
4102 st
= next_statement ();
4105 if (st
== ST_END_SELECT
)
4107 /* Empty SELECT CASE is OK. */
4108 accept_statement (st
);
4115 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
4118 reject_statement ();
4121 /* At this point, we're got a nonempty select block. */
4122 cp
= new_level (cp
);
4125 accept_statement (st
);
4129 st
= parse_executable (ST_NONE
);
4136 cp
= new_level (gfc_state_stack
->head
);
4138 gfc_clear_new_st ();
4140 accept_statement (st
);
4146 /* Can't have an executable statement because of
4147 parse_executable(). */
4149 unexpected_statement (st
);
4153 while (st
!= ST_END_SELECT
);
4156 accept_statement (st
);
4160 /* Pop the current selector from the SELECT TYPE stack. */
4163 select_type_pop (void)
4165 gfc_select_type_stack
*old
= select_type_stack
;
4166 select_type_stack
= old
->prev
;
4171 /* Parse a SELECT TYPE construct (F03:R821). */
4174 parse_select_type_block (void)
4180 gfc_current_ns
= new_st
.ext
.block
.ns
;
4181 accept_statement (ST_SELECT_TYPE
);
4183 cp
= gfc_state_stack
->tail
;
4184 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
4186 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
4190 st
= next_statement ();
4193 if (st
== ST_END_SELECT
)
4194 /* Empty SELECT CASE is OK. */
4196 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
4199 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
4200 "following SELECT TYPE at %C");
4202 reject_statement ();
4205 /* At this point, we're got a nonempty select block. */
4206 cp
= new_level (cp
);
4209 accept_statement (st
);
4213 st
= parse_executable (ST_NONE
);
4221 cp
= new_level (gfc_state_stack
->head
);
4223 gfc_clear_new_st ();
4225 accept_statement (st
);
4231 /* Can't have an executable statement because of
4232 parse_executable(). */
4234 unexpected_statement (st
);
4238 while (st
!= ST_END_SELECT
);
4242 accept_statement (st
);
4243 gfc_current_ns
= gfc_current_ns
->parent
;
4248 /* Given a symbol, make sure it is not an iteration variable for a DO
4249 statement. This subroutine is called when the symbol is seen in a
4250 context that causes it to become redefined. If the symbol is an
4251 iterator, we generate an error message and return nonzero. */
4254 gfc_check_do_variable (gfc_symtree
*st
)
4258 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
4259 if (s
->do_variable
== st
)
4261 gfc_error_now ("Variable %qs at %C cannot be redefined inside "
4262 "loop beginning at %L", st
->name
, &s
->head
->loc
);
4270 /* Checks to see if the current statement label closes an enddo.
4271 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
4272 an error) if it incorrectly closes an ENDDO. */
4275 check_do_closure (void)
4279 if (gfc_statement_label
== NULL
)
4282 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
4283 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4287 return 0; /* No loops to close */
4289 if (p
->ext
.end_do_label
== gfc_statement_label
)
4291 if (p
== gfc_state_stack
)
4294 gfc_error ("End of nonblock DO statement at %C is within another block");
4298 /* At this point, the label doesn't terminate the innermost loop.
4299 Make sure it doesn't terminate another one. */
4300 for (; p
; p
= p
->previous
)
4301 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4302 && p
->ext
.end_do_label
== gfc_statement_label
)
4304 gfc_error ("End of nonblock DO statement at %C is interwoven "
4305 "with another DO loop");
4313 /* Parse a series of contained program units. */
4315 static void parse_progunit (gfc_statement
);
4318 /* Parse a CRITICAL block. */
4321 parse_critical_block (void)
4324 gfc_state_data s
, *sd
;
4327 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4328 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
4329 gfc_error_now (is_oacc (sd
)
4330 ? "CRITICAL block inside of OpenACC region at %C"
4331 : "CRITICAL block inside of OpenMP region at %C");
4333 s
.ext
.end_do_label
= new_st
.label1
;
4335 accept_statement (ST_CRITICAL
);
4336 top
= gfc_state_stack
->tail
;
4338 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
4340 d
= add_statement ();
4341 d
->op
= EXEC_CRITICAL
;
4346 st
= parse_executable (ST_NONE
);
4354 case ST_END_CRITICAL
:
4355 if (s
.ext
.end_do_label
!= NULL
4356 && s
.ext
.end_do_label
!= gfc_statement_label
)
4357 gfc_error_now ("Statement label in END CRITICAL at %C does not "
4358 "match CRITICAL label");
4360 if (gfc_statement_label
!= NULL
)
4362 new_st
.op
= EXEC_NOP
;
4368 unexpected_statement (st
);
4372 while (st
!= ST_END_CRITICAL
);
4375 accept_statement (st
);
4379 /* Set up the local namespace for a BLOCK construct. */
4382 gfc_build_block_ns (gfc_namespace
*parent_ns
)
4384 gfc_namespace
* my_ns
;
4385 static int numblock
= 1;
4387 my_ns
= gfc_get_namespace (parent_ns
, 1);
4388 my_ns
->construct_entities
= 1;
4390 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
4391 code generation (so it must not be NULL).
4392 We set its recursive argument if our container procedure is recursive, so
4393 that local variables are accordingly placed on the stack when it
4394 will be necessary. */
4396 my_ns
->proc_name
= gfc_new_block
;
4400 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
4402 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
4403 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
4404 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
4405 my_ns
->proc_name
->name
, NULL
);
4407 gfc_commit_symbol (my_ns
->proc_name
);
4410 if (parent_ns
->proc_name
)
4411 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
4417 /* Parse a BLOCK construct. */
4420 parse_block_construct (void)
4422 gfc_namespace
* my_ns
;
4423 gfc_namespace
* my_parent
;
4426 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
4428 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4430 new_st
.op
= EXEC_BLOCK
;
4431 new_st
.ext
.block
.ns
= my_ns
;
4432 new_st
.ext
.block
.assoc
= NULL
;
4433 accept_statement (ST_BLOCK
);
4435 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
4436 gfc_current_ns
= my_ns
;
4437 my_parent
= my_ns
->parent
;
4439 parse_progunit (ST_NONE
);
4441 /* Don't depend on the value of gfc_current_ns; it might have been
4442 reset if the block had errors and was cleaned up. */
4443 gfc_current_ns
= my_parent
;
4449 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
4450 behind the scenes with compiler-generated variables. */
4453 parse_associate (void)
4455 gfc_namespace
* my_ns
;
4458 gfc_association_list
* a
;
4460 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
4462 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4464 new_st
.op
= EXEC_BLOCK
;
4465 new_st
.ext
.block
.ns
= my_ns
;
4466 gcc_assert (new_st
.ext
.block
.assoc
);
4468 /* Add all associate-names as BLOCK variables. Creating them is enough
4469 for now, they'll get their values during trans-* phase. */
4470 gfc_current_ns
= my_ns
;
4471 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
4475 gfc_array_ref
*array_ref
;
4477 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
4481 sym
->attr
.flavor
= FL_VARIABLE
;
4483 sym
->declared_at
= a
->where
;
4484 gfc_set_sym_referenced (sym
);
4486 /* Initialize the typespec. It is not available in all cases,
4487 however, as it may only be set on the target during resolution.
4488 Still, sometimes it helps to have it right now -- especially
4489 for parsing component references on the associate-name
4490 in case of association to a derived-type. */
4491 sym
->ts
= a
->target
->ts
;
4493 /* Check if the target expression is array valued. This can not always
4494 be done by looking at target.rank, because that might not have been
4495 set yet. Therefore traverse the chain of refs, looking for the last
4496 array ref and evaluate that. */
4498 for (ref
= a
->target
->ref
; ref
; ref
= ref
->next
)
4499 if (ref
->type
== REF_ARRAY
)
4500 array_ref
= &ref
->u
.ar
;
4501 if (array_ref
|| a
->target
->rank
)
4508 /* Count the dimension, that have a non-scalar extend. */
4509 for (dim
= 0; dim
< array_ref
->dimen
; ++dim
)
4510 if (array_ref
->dimen_type
[dim
] != DIMEN_ELEMENT
4511 && !(array_ref
->dimen_type
[dim
] == DIMEN_UNKNOWN
4512 && array_ref
->end
[dim
] == NULL
4513 && array_ref
->start
[dim
] != NULL
))
4517 rank
= a
->target
->rank
;
4518 /* When the rank is greater than zero then sym will be an array. */
4519 if (sym
->ts
.type
== BT_CLASS
)
4521 if ((!CLASS_DATA (sym
)->as
&& rank
!= 0)
4522 || (CLASS_DATA (sym
)->as
4523 && CLASS_DATA (sym
)->as
->rank
!= rank
))
4525 /* Don't just (re-)set the attr and as in the sym.ts,
4526 because this modifies the target's attr and as. Copy the
4527 data and do a build_class_symbol. */
4528 symbol_attribute attr
= CLASS_DATA (a
->target
)->attr
;
4529 int corank
= gfc_get_corank (a
->target
);
4534 as
= gfc_get_array_spec ();
4535 as
->type
= AS_DEFERRED
;
4537 as
->corank
= corank
;
4538 attr
.dimension
= rank
? 1 : 0;
4539 attr
.codimension
= corank
? 1 : 0;
4544 attr
.dimension
= attr
.codimension
= 0;
4547 type
= CLASS_DATA (sym
)->ts
;
4548 if (!gfc_build_class_symbol (&type
,
4552 sym
->ts
.type
= BT_CLASS
;
4553 sym
->attr
.class_ok
= 1;
4556 sym
->attr
.class_ok
= 1;
4558 else if ((!sym
->as
&& rank
!= 0)
4559 || (sym
->as
&& sym
->as
->rank
!= rank
))
4561 as
= gfc_get_array_spec ();
4562 as
->type
= AS_DEFERRED
;
4564 as
->corank
= gfc_get_corank (a
->target
);
4566 sym
->attr
.dimension
= 1;
4568 sym
->attr
.codimension
= 1;
4573 accept_statement (ST_ASSOCIATE
);
4574 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
4577 st
= parse_executable (ST_NONE
);
4584 accept_statement (st
);
4585 my_ns
->code
= gfc_state_stack
->head
;
4589 unexpected_statement (st
);
4593 gfc_current_ns
= gfc_current_ns
->parent
;
4598 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
4599 handled inside of parse_executable(), because they aren't really
4603 parse_do_block (void)
4612 s
.ext
.end_do_label
= new_st
.label1
;
4614 if (new_st
.ext
.iterator
!= NULL
)
4615 stree
= new_st
.ext
.iterator
->var
->symtree
;
4619 accept_statement (ST_DO
);
4621 top
= gfc_state_stack
->tail
;
4622 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
4625 s
.do_variable
= stree
;
4627 top
->block
= new_level (top
);
4628 top
->block
->op
= EXEC_DO
;
4631 st
= parse_executable (ST_NONE
);
4639 if (s
.ext
.end_do_label
!= NULL
4640 && s
.ext
.end_do_label
!= gfc_statement_label
)
4641 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
4644 if (gfc_statement_label
!= NULL
)
4646 new_st
.op
= EXEC_NOP
;
4651 case ST_IMPLIED_ENDDO
:
4652 /* If the do-stmt of this DO construct has a do-construct-name,
4653 the corresponding end-do must be an end-do-stmt (with a matching
4654 name, but in that case we must have seen ST_ENDDO first).
4655 We only complain about this in pedantic mode. */
4656 if (gfc_current_block () != NULL
)
4657 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
4658 &gfc_current_block()->declared_at
);
4663 unexpected_statement (st
);
4668 accept_statement (st
);
4672 /* Parse the statements of OpenMP do/parallel do. */
4674 static gfc_statement
4675 parse_omp_do (gfc_statement omp_st
)
4681 accept_statement (omp_st
);
4683 cp
= gfc_state_stack
->tail
;
4684 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4685 np
= new_level (cp
);
4691 st
= next_statement ();
4694 else if (st
== ST_DO
)
4697 unexpected_statement (st
);
4701 if (gfc_statement_label
!= NULL
4702 && gfc_state_stack
->previous
!= NULL
4703 && gfc_state_stack
->previous
->state
== COMP_DO
4704 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4712 there should be no !$OMP END DO. */
4714 return ST_IMPLIED_ENDDO
;
4717 check_do_closure ();
4720 st
= next_statement ();
4721 gfc_statement omp_end_st
= ST_OMP_END_DO
;
4724 case ST_OMP_DISTRIBUTE
: omp_end_st
= ST_OMP_END_DISTRIBUTE
; break;
4725 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4726 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4728 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4729 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4731 case ST_OMP_DISTRIBUTE_SIMD
:
4732 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4734 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
4735 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
4736 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
4737 case ST_OMP_PARALLEL_DO_SIMD
:
4738 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
4740 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
4741 case ST_OMP_TARGET_PARALLEL_DO
:
4742 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO
;
4744 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
4745 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO_SIMD
;
4747 case ST_OMP_TARGET_SIMD
: omp_end_st
= ST_OMP_END_TARGET_SIMD
; break;
4748 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4749 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4751 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4752 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4754 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4755 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4757 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4758 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4760 case ST_OMP_TASKLOOP
: omp_end_st
= ST_OMP_END_TASKLOOP
; break;
4761 case ST_OMP_TASKLOOP_SIMD
: omp_end_st
= ST_OMP_END_TASKLOOP_SIMD
; break;
4762 case ST_OMP_TEAMS_DISTRIBUTE
:
4763 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4765 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4766 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4768 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4769 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4771 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4772 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4774 default: gcc_unreachable ();
4776 if (st
== omp_end_st
)
4778 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
4779 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4781 gcc_assert (new_st
.op
== EXEC_NOP
);
4782 gfc_clear_new_st ();
4783 gfc_commit_symbols ();
4784 gfc_warning_check ();
4785 st
= next_statement ();
4791 /* Parse the statements of OpenMP atomic directive. */
4793 static gfc_statement
4794 parse_omp_oacc_atomic (bool omp_p
)
4796 gfc_statement st
, st_atomic
, st_end_atomic
;
4803 st_atomic
= ST_OMP_ATOMIC
;
4804 st_end_atomic
= ST_OMP_END_ATOMIC
;
4808 st_atomic
= ST_OACC_ATOMIC
;
4809 st_end_atomic
= ST_OACC_END_ATOMIC
;
4811 accept_statement (st_atomic
);
4813 cp
= gfc_state_stack
->tail
;
4814 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4815 np
= new_level (cp
);
4818 np
->ext
.omp_atomic
= cp
->ext
.omp_atomic
;
4819 count
= 1 + ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4820 == GFC_OMP_ATOMIC_CAPTURE
);
4824 st
= next_statement ();
4827 else if (st
== ST_ASSIGNMENT
)
4829 accept_statement (st
);
4833 unexpected_statement (st
);
4838 st
= next_statement ();
4839 if (st
== st_end_atomic
)
4841 gfc_clear_new_st ();
4842 gfc_commit_symbols ();
4843 gfc_warning_check ();
4844 st
= next_statement ();
4846 else if ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4847 == GFC_OMP_ATOMIC_CAPTURE
)
4848 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
4853 /* Parse the statements of an OpenACC structured block. */
4856 parse_oacc_structured_block (gfc_statement acc_st
)
4858 gfc_statement st
, acc_end_st
;
4860 gfc_state_data s
, *sd
;
4862 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4863 if (sd
->state
== COMP_CRITICAL
)
4864 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4866 accept_statement (acc_st
);
4868 cp
= gfc_state_stack
->tail
;
4869 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4870 np
= new_level (cp
);
4875 case ST_OACC_PARALLEL
:
4876 acc_end_st
= ST_OACC_END_PARALLEL
;
4878 case ST_OACC_KERNELS
:
4879 acc_end_st
= ST_OACC_END_KERNELS
;
4882 acc_end_st
= ST_OACC_END_DATA
;
4884 case ST_OACC_HOST_DATA
:
4885 acc_end_st
= ST_OACC_END_HOST_DATA
;
4893 st
= parse_executable (ST_NONE
);
4896 else if (st
!= acc_end_st
)
4898 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
4899 reject_statement ();
4902 while (st
!= acc_end_st
);
4904 gcc_assert (new_st
.op
== EXEC_NOP
);
4906 gfc_clear_new_st ();
4907 gfc_commit_symbols ();
4908 gfc_warning_check ();
4912 /* Parse the statements of OpenACC loop/parallel loop/kernels loop. */
4914 static gfc_statement
4915 parse_oacc_loop (gfc_statement acc_st
)
4919 gfc_state_data s
, *sd
;
4921 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4922 if (sd
->state
== COMP_CRITICAL
)
4923 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4925 accept_statement (acc_st
);
4927 cp
= gfc_state_stack
->tail
;
4928 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4929 np
= new_level (cp
);
4935 st
= next_statement ();
4938 else if (st
== ST_DO
)
4942 gfc_error ("Expected DO loop at %C");
4943 reject_statement ();
4948 if (gfc_statement_label
!= NULL
4949 && gfc_state_stack
->previous
!= NULL
4950 && gfc_state_stack
->previous
->state
== COMP_DO
4951 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4954 return ST_IMPLIED_ENDDO
;
4957 check_do_closure ();
4960 st
= next_statement ();
4961 if (st
== ST_OACC_END_LOOP
)
4962 gfc_warning (0, "Redundant !$ACC END LOOP at %C");
4963 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
4964 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
4965 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
4967 gcc_assert (new_st
.op
== EXEC_NOP
);
4968 gfc_clear_new_st ();
4969 gfc_commit_symbols ();
4970 gfc_warning_check ();
4971 st
= next_statement ();
4977 /* Parse the statements of an OpenMP structured block. */
4980 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
4982 gfc_statement st
, omp_end_st
;
4986 accept_statement (omp_st
);
4988 cp
= gfc_state_stack
->tail
;
4989 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4990 np
= new_level (cp
);
4996 case ST_OMP_PARALLEL
:
4997 omp_end_st
= ST_OMP_END_PARALLEL
;
4999 case ST_OMP_PARALLEL_SECTIONS
:
5000 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
5002 case ST_OMP_SECTIONS
:
5003 omp_end_st
= ST_OMP_END_SECTIONS
;
5005 case ST_OMP_ORDERED
:
5006 omp_end_st
= ST_OMP_END_ORDERED
;
5008 case ST_OMP_CRITICAL
:
5009 omp_end_st
= ST_OMP_END_CRITICAL
;
5012 omp_end_st
= ST_OMP_END_MASTER
;
5015 omp_end_st
= ST_OMP_END_SINGLE
;
5018 omp_end_st
= ST_OMP_END_TARGET
;
5020 case ST_OMP_TARGET_DATA
:
5021 omp_end_st
= ST_OMP_END_TARGET_DATA
;
5023 case ST_OMP_TARGET_TEAMS
:
5024 omp_end_st
= ST_OMP_END_TARGET_TEAMS
;
5026 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5027 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
5029 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5030 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5032 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5033 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5035 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5036 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
5039 omp_end_st
= ST_OMP_END_TASK
;
5041 case ST_OMP_TASKGROUP
:
5042 omp_end_st
= ST_OMP_END_TASKGROUP
;
5045 omp_end_st
= ST_OMP_END_TEAMS
;
5047 case ST_OMP_TEAMS_DISTRIBUTE
:
5048 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
5050 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5051 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5053 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5054 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5056 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5057 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
5059 case ST_OMP_DISTRIBUTE
:
5060 omp_end_st
= ST_OMP_END_DISTRIBUTE
;
5062 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5063 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
5065 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5066 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
5068 case ST_OMP_DISTRIBUTE_SIMD
:
5069 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
5071 case ST_OMP_WORKSHARE
:
5072 omp_end_st
= ST_OMP_END_WORKSHARE
;
5074 case ST_OMP_PARALLEL_WORKSHARE
:
5075 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
5083 if (workshare_stmts_only
)
5085 /* Inside of !$omp workshare, only
5088 where statements and constructs
5089 forall statements and constructs
5093 are allowed. For !$omp critical these
5094 restrictions apply recursively. */
5097 st
= next_statement ();
5108 accept_statement (st
);
5111 case ST_WHERE_BLOCK
:
5112 parse_where_block ();
5115 case ST_FORALL_BLOCK
:
5116 parse_forall_block ();
5119 case ST_OMP_PARALLEL
:
5120 case ST_OMP_PARALLEL_SECTIONS
:
5121 parse_omp_structured_block (st
, false);
5124 case ST_OMP_PARALLEL_WORKSHARE
:
5125 case ST_OMP_CRITICAL
:
5126 parse_omp_structured_block (st
, true);
5129 case ST_OMP_PARALLEL_DO
:
5130 case ST_OMP_PARALLEL_DO_SIMD
:
5131 st
= parse_omp_do (st
);
5135 st
= parse_omp_oacc_atomic (true);
5146 st
= next_statement ();
5150 st
= parse_executable (ST_NONE
);
5153 else if (st
== ST_OMP_SECTION
5154 && (omp_st
== ST_OMP_SECTIONS
5155 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
5157 np
= new_level (np
);
5161 else if (st
!= omp_end_st
)
5162 unexpected_statement (st
);
5164 while (st
!= omp_end_st
);
5168 case EXEC_OMP_END_NOWAIT
:
5169 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
5171 case EXEC_OMP_END_CRITICAL
:
5172 if (((cp
->ext
.omp_clauses
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
5173 || (new_st
.ext
.omp_name
!= NULL
5174 && strcmp (cp
->ext
.omp_clauses
->critical_name
,
5175 new_st
.ext
.omp_name
) != 0))
5176 gfc_error ("Name after !$omp critical and !$omp end critical does "
5178 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
5179 new_st
.ext
.omp_name
= NULL
;
5181 case EXEC_OMP_END_SINGLE
:
5182 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
5183 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
5184 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
5185 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
5193 gfc_clear_new_st ();
5194 gfc_commit_symbols ();
5195 gfc_warning_check ();
5200 /* Accept a series of executable statements. We return the first
5201 statement that doesn't fit to the caller. Any block statements are
5202 passed on to the correct handler, which usually passes the buck
5205 static gfc_statement
5206 parse_executable (gfc_statement st
)
5211 st
= next_statement ();
5215 close_flag
= check_do_closure ();
5220 case ST_END_PROGRAM
:
5223 case ST_END_FUNCTION
:
5228 case ST_END_SUBROUTINE
:
5233 case ST_SELECT_CASE
:
5234 gfc_error ("%s statement at %C cannot terminate a non-block "
5235 "DO loop", gfc_ascii_statement (st
));
5248 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
5249 "first executable statement");
5255 accept_statement (st
);
5256 if (close_flag
== 1)
5257 return ST_IMPLIED_ENDDO
;
5261 parse_block_construct ();
5272 case ST_SELECT_CASE
:
5273 parse_select_block ();
5276 case ST_SELECT_TYPE
:
5277 parse_select_type_block ();
5282 if (check_do_closure () == 1)
5283 return ST_IMPLIED_ENDDO
;
5287 parse_critical_block ();
5290 case ST_WHERE_BLOCK
:
5291 parse_where_block ();
5294 case ST_FORALL_BLOCK
:
5295 parse_forall_block ();
5298 case ST_OACC_PARALLEL_LOOP
:
5299 case ST_OACC_KERNELS_LOOP
:
5301 st
= parse_oacc_loop (st
);
5302 if (st
== ST_IMPLIED_ENDDO
)
5306 case ST_OACC_PARALLEL
:
5307 case ST_OACC_KERNELS
:
5309 case ST_OACC_HOST_DATA
:
5310 parse_oacc_structured_block (st
);
5313 case ST_OMP_PARALLEL
:
5314 case ST_OMP_PARALLEL_SECTIONS
:
5315 case ST_OMP_SECTIONS
:
5316 case ST_OMP_ORDERED
:
5317 case ST_OMP_CRITICAL
:
5321 case ST_OMP_TARGET_DATA
:
5322 case ST_OMP_TARGET_PARALLEL
:
5323 case ST_OMP_TARGET_TEAMS
:
5326 case ST_OMP_TASKGROUP
:
5327 parse_omp_structured_block (st
, false);
5330 case ST_OMP_WORKSHARE
:
5331 case ST_OMP_PARALLEL_WORKSHARE
:
5332 parse_omp_structured_block (st
, true);
5335 case ST_OMP_DISTRIBUTE
:
5336 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5337 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5338 case ST_OMP_DISTRIBUTE_SIMD
:
5340 case ST_OMP_DO_SIMD
:
5341 case ST_OMP_PARALLEL_DO
:
5342 case ST_OMP_PARALLEL_DO_SIMD
:
5344 case ST_OMP_TARGET_PARALLEL_DO
:
5345 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
5346 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5347 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5348 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5349 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5350 case ST_OMP_TASKLOOP
:
5351 case ST_OMP_TASKLOOP_SIMD
:
5352 case ST_OMP_TEAMS_DISTRIBUTE
:
5353 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5354 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5355 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5356 st
= parse_omp_do (st
);
5357 if (st
== ST_IMPLIED_ENDDO
)
5361 case ST_OACC_ATOMIC
:
5362 st
= parse_omp_oacc_atomic (false);
5366 st
= parse_omp_oacc_atomic (true);
5373 st
= next_statement ();
5378 /* Fix the symbols for sibling functions. These are incorrectly added to
5379 the child namespace as the parser didn't know about this procedure. */
5382 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
5386 gfc_symbol
*old_sym
;
5388 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
5390 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
5392 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
5393 goto fixup_contained
;
5395 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
5396 && sym
->attr
.generic
&& sym
->attr
.function
)
5397 ||(sym
->attr
.flavor
== FL_DERIVED
5398 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
5399 goto fixup_contained
;
5401 old_sym
= st
->n
.sym
;
5402 if (old_sym
->ns
== ns
5403 && !old_sym
->attr
.contained
5405 /* By 14.6.1.3, host association should be excluded
5406 for the following. */
5407 && !(old_sym
->attr
.external
5408 || (old_sym
->ts
.type
!= BT_UNKNOWN
5409 && !old_sym
->attr
.implicit_type
)
5410 || old_sym
->attr
.flavor
== FL_PARAMETER
5411 || old_sym
->attr
.use_assoc
5412 || old_sym
->attr
.in_common
5413 || old_sym
->attr
.in_equivalence
5414 || old_sym
->attr
.data
5415 || old_sym
->attr
.dummy
5416 || old_sym
->attr
.result
5417 || old_sym
->attr
.dimension
5418 || old_sym
->attr
.allocatable
5419 || old_sym
->attr
.intrinsic
5420 || old_sym
->attr
.generic
5421 || old_sym
->attr
.flavor
== FL_NAMELIST
5422 || old_sym
->attr
.flavor
== FL_LABEL
5423 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
5425 /* Replace it with the symbol from the parent namespace. */
5429 gfc_release_symbol (old_sym
);
5433 /* Do the same for any contained procedures. */
5434 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
5439 parse_contained (int module
)
5441 gfc_namespace
*ns
, *parent_ns
, *tmp
;
5442 gfc_state_data s1
, s2
;
5447 int contains_statements
= 0;
5450 push_state (&s1
, COMP_CONTAINS
, NULL
);
5451 parent_ns
= gfc_current_ns
;
5455 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
5457 gfc_current_ns
->sibling
= parent_ns
->contained
;
5458 parent_ns
->contained
= gfc_current_ns
;
5461 /* Process the next available statement. We come here if we got an error
5462 and rejected the last statement. */
5463 old_loc
= gfc_current_locus
;
5464 st
= next_statement ();
5473 contains_statements
= 1;
5474 accept_statement (st
);
5477 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
5480 /* For internal procedures, create/update the symbol in the
5481 parent namespace. */
5485 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
5486 gfc_error ("Contained procedure %qs at %C is already "
5487 "ambiguous", gfc_new_block
->name
);
5490 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
5492 &gfc_new_block
->declared_at
))
5494 if (st
== ST_FUNCTION
)
5495 gfc_add_function (&sym
->attr
, sym
->name
,
5496 &gfc_new_block
->declared_at
);
5498 gfc_add_subroutine (&sym
->attr
, sym
->name
,
5499 &gfc_new_block
->declared_at
);
5503 gfc_commit_symbols ();
5506 sym
= gfc_new_block
;
5508 /* Mark this as a contained function, so it isn't replaced
5509 by other module functions. */
5510 sym
->attr
.contained
= 1;
5512 /* Set implicit_pure so that it can be reset if any of the
5513 tests for purity fail. This is used for some optimisation
5514 during translation. */
5515 if (!sym
->attr
.pure
)
5516 sym
->attr
.implicit_pure
= 1;
5518 parse_progunit (ST_NONE
);
5520 /* Fix up any sibling functions that refer to this one. */
5521 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
5522 /* Or refer to any of its alternate entry points. */
5523 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
5524 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
5526 gfc_current_ns
->code
= s2
.head
;
5527 gfc_current_ns
= parent_ns
;
5532 /* These statements are associated with the end of the host unit. */
5533 case ST_END_FUNCTION
:
5535 case ST_END_SUBMODULE
:
5536 case ST_END_PROGRAM
:
5537 case ST_END_SUBROUTINE
:
5538 accept_statement (st
);
5539 gfc_current_ns
->code
= s1
.head
;
5543 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
5544 gfc_ascii_statement (st
));
5545 reject_statement ();
5551 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
5552 && st
!= ST_END_MODULE
&& st
!= ST_END_SUBMODULE
5553 && st
!= ST_END_PROGRAM
);
5555 /* The first namespace in the list is guaranteed to not have
5556 anything (worthwhile) in it. */
5557 tmp
= gfc_current_ns
;
5558 gfc_current_ns
= parent_ns
;
5559 if (seen_error
&& tmp
->refs
> 1)
5560 gfc_free_namespace (tmp
);
5562 ns
= gfc_current_ns
->contained
;
5563 gfc_current_ns
->contained
= ns
->sibling
;
5564 gfc_free_namespace (ns
);
5567 if (!contains_statements
)
5568 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
5569 "FUNCTION or SUBROUTINE statement at %L", &old_loc
);
5573 /* The result variable in a MODULE PROCEDURE needs to be created and
5574 its characteristics copied from the interface since it is neither
5575 declared in the procedure declaration nor in the specification
5579 get_modproc_result (void)
5582 if (gfc_state_stack
->previous
5583 && gfc_state_stack
->previous
->state
== COMP_CONTAINS
5584 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
5586 proc
= gfc_current_ns
->proc_name
? gfc_current_ns
->proc_name
: NULL
;
5588 && proc
->attr
.function
5589 && proc
->ts
.interface
5590 && proc
->ts
.interface
->result
5591 && proc
->ts
.interface
->result
!= proc
->ts
.interface
)
5593 gfc_copy_dummy_sym (&proc
->result
, proc
->ts
.interface
->result
, 1);
5594 gfc_set_sym_referenced (proc
->result
);
5595 proc
->result
->attr
.if_source
= IFSRC_DECL
;
5596 gfc_commit_symbol (proc
->result
);
5602 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
5605 parse_progunit (gfc_statement st
)
5611 && gfc_new_block
->abr_modproc_decl
5612 && gfc_new_block
->attr
.function
)
5613 get_modproc_result ();
5615 st
= parse_spec (st
);
5622 /* This is not allowed within BLOCK! */
5623 if (gfc_current_state () != COMP_BLOCK
)
5628 accept_statement (st
);
5635 if (gfc_current_state () == COMP_FUNCTION
)
5636 gfc_check_function_type (gfc_current_ns
);
5641 st
= parse_executable (st
);
5649 /* This is not allowed within BLOCK! */
5650 if (gfc_current_state () != COMP_BLOCK
)
5655 accept_statement (st
);
5662 unexpected_statement (st
);
5663 reject_statement ();
5664 st
= next_statement ();
5670 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
5671 if (p
->state
== COMP_CONTAINS
)
5674 if (gfc_find_state (COMP_MODULE
) == true
5675 || gfc_find_state (COMP_SUBMODULE
) == true)
5680 gfc_error ("CONTAINS statement at %C is already in a contained "
5682 reject_statement ();
5683 st
= next_statement ();
5687 parse_contained (0);
5690 gfc_current_ns
->code
= gfc_state_stack
->head
;
5694 /* Come here to complain about a global symbol already in use as
5698 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
5703 where
= &gfc_current_locus
;
5713 case GSYM_SUBROUTINE
:
5714 name
= "SUBROUTINE";
5719 case GSYM_BLOCK_DATA
:
5720 name
= "BLOCK DATA";
5726 gfc_internal_error ("gfc_global_used(): Bad type");
5730 if (sym
->binding_label
)
5731 gfc_error ("Global binding name %qs at %L is already being used as a %s "
5732 "at %L", sym
->binding_label
, where
, name
, &sym
->where
);
5734 gfc_error ("Global name %qs at %L is already being used as a %s at %L",
5735 sym
->name
, where
, name
, &sym
->where
);
5739 /* Parse a block data program unit. */
5742 parse_block_data (void)
5745 static locus blank_locus
;
5746 static int blank_block
=0;
5749 gfc_current_ns
->proc_name
= gfc_new_block
;
5750 gfc_current_ns
->is_block_data
= 1;
5752 if (gfc_new_block
== NULL
)
5755 gfc_error ("Blank BLOCK DATA at %C conflicts with "
5756 "prior BLOCK DATA at %L", &blank_locus
);
5760 blank_locus
= gfc_current_locus
;
5765 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5767 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
5768 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5771 s
->type
= GSYM_BLOCK_DATA
;
5772 s
->where
= gfc_new_block
->declared_at
;
5777 st
= parse_spec (ST_NONE
);
5779 while (st
!= ST_END_BLOCK_DATA
)
5781 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
5782 gfc_ascii_statement (st
));
5783 reject_statement ();
5784 st
= next_statement ();
5789 /* Following the association of the ancestor (sub)module symbols, they
5790 must be set host rather than use associated and all must be public.
5791 They are flagged up by 'used_in_submodule' so that they can be set
5792 DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
5793 linker chokes on multiple symbol definitions. */
5796 set_syms_host_assoc (gfc_symbol
*sym
)
5803 if (sym
->attr
.module_procedure
)
5804 sym
->attr
.external
= 0;
5806 /* sym->attr.access = ACCESS_PUBLIC; */
5808 sym
->attr
.use_assoc
= 0;
5809 sym
->attr
.host_assoc
= 1;
5810 sym
->attr
.used_in_submodule
=1;
5812 if (sym
->attr
.flavor
== FL_DERIVED
)
5814 for (c
= sym
->components
; c
; c
= c
->next
)
5815 c
->attr
.access
= ACCESS_PUBLIC
;
5819 /* Parse a module subprogram. */
5828 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5829 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
5830 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5833 s
->type
= GSYM_MODULE
;
5834 s
->where
= gfc_new_block
->declared_at
;
5838 /* Something is nulling the module_list after this point. This is good
5839 since it allows us to 'USE' the parent modules that the submodule
5840 inherits and to set (most) of the symbols as host associated. */
5841 if (gfc_current_state () == COMP_SUBMODULE
)
5844 gfc_traverse_ns (gfc_current_ns
, set_syms_host_assoc
);
5847 st
= parse_spec (ST_NONE
);
5857 parse_contained (1);
5861 case ST_END_SUBMODULE
:
5862 accept_statement (st
);
5866 gfc_error ("Unexpected %s statement in MODULE at %C",
5867 gfc_ascii_statement (st
));
5870 reject_statement ();
5871 st
= next_statement ();
5875 /* Make sure not to free the namespace twice on error. */
5877 s
->ns
= gfc_current_ns
;
5881 /* Add a procedure name to the global symbol table. */
5884 add_global_procedure (bool sub
)
5888 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5889 name is a global identifier. */
5890 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5892 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5895 || (s
->type
!= GSYM_UNKNOWN
5896 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5898 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5899 /* Silence follow-up errors. */
5900 gfc_new_block
->binding_label
= NULL
;
5904 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5905 s
->sym_name
= gfc_new_block
->name
;
5906 s
->where
= gfc_new_block
->declared_at
;
5908 s
->ns
= gfc_current_ns
;
5912 /* Don't add the symbol multiple times. */
5913 if (gfc_new_block
->binding_label
5914 && (!gfc_notification_std (GFC_STD_F2008
)
5915 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
5917 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
);
5920 || (s
->type
!= GSYM_UNKNOWN
5921 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5923 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5924 /* Silence follow-up errors. */
5925 gfc_new_block
->binding_label
= NULL
;
5929 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5930 s
->sym_name
= gfc_new_block
->name
;
5931 s
->binding_label
= gfc_new_block
->binding_label
;
5932 s
->where
= gfc_new_block
->declared_at
;
5934 s
->ns
= gfc_current_ns
;
5940 /* Add a program to the global symbol table. */
5943 add_global_program (void)
5947 if (gfc_new_block
== NULL
)
5949 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5951 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
5952 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5955 s
->type
= GSYM_PROGRAM
;
5956 s
->where
= gfc_new_block
->declared_at
;
5958 s
->ns
= gfc_current_ns
;
5963 /* Resolve all the program units. */
5965 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
5967 gfc_free_dt_list ();
5968 gfc_current_ns
= gfc_global_ns_list
;
5969 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5971 if (gfc_current_ns
->proc_name
5972 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5973 continue; /* Already resolved. */
5975 if (gfc_current_ns
->proc_name
)
5976 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5977 gfc_resolve (gfc_current_ns
);
5978 gfc_current_ns
->derived_types
= gfc_derived_types
;
5979 gfc_derived_types
= NULL
;
5985 clean_up_modules (gfc_gsymbol
*gsym
)
5990 clean_up_modules (gsym
->left
);
5991 clean_up_modules (gsym
->right
);
5993 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
5996 gfc_current_ns
= gsym
->ns
;
5997 gfc_derived_types
= gfc_current_ns
->derived_types
;
6004 /* Translate all the program units. This could be in a different order
6005 to resolution if there are forward references in the file. */
6007 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
6011 gfc_current_ns
= gfc_global_ns_list
;
6012 gfc_get_errors (NULL
, &errors
);
6014 /* We first translate all modules to make sure that later parts
6015 of the program can use the decl. Then we translate the nonmodules. */
6017 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6019 if (!gfc_current_ns
->proc_name
6020 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6023 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6024 gfc_derived_types
= gfc_current_ns
->derived_types
;
6025 gfc_generate_module_code (gfc_current_ns
);
6026 gfc_current_ns
->translated
= 1;
6029 gfc_current_ns
= gfc_global_ns_list
;
6030 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6032 if (gfc_current_ns
->proc_name
6033 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6036 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6037 gfc_derived_types
= gfc_current_ns
->derived_types
;
6038 gfc_generate_code (gfc_current_ns
);
6039 gfc_current_ns
->translated
= 1;
6042 /* Clean up all the namespaces after translation. */
6043 gfc_current_ns
= gfc_global_ns_list
;
6044 for (;gfc_current_ns
;)
6048 if (gfc_current_ns
->proc_name
6049 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6051 gfc_current_ns
= gfc_current_ns
->sibling
;
6055 ns
= gfc_current_ns
->sibling
;
6056 gfc_derived_types
= gfc_current_ns
->derived_types
;
6058 gfc_current_ns
= ns
;
6061 clean_up_modules (gfc_gsym_root
);
6065 /* Top level parser. */
6068 gfc_parse_file (void)
6070 int seen_program
, errors_before
, errors
;
6071 gfc_state_data top
, s
;
6074 gfc_namespace
*next
;
6076 gfc_start_source_files ();
6078 top
.state
= COMP_NONE
;
6080 top
.previous
= NULL
;
6081 top
.head
= top
.tail
= NULL
;
6082 top
.do_variable
= NULL
;
6084 gfc_state_stack
= &top
;
6086 gfc_clear_new_st ();
6088 gfc_statement_label
= NULL
;
6090 if (setjmp (eof_buf
))
6091 return false; /* Come here on unexpected EOF */
6093 /* Prepare the global namespace that will contain the
6095 gfc_global_ns_list
= next
= NULL
;
6100 /* Exit early for empty files. */
6104 in_specification_block
= true;
6107 st
= next_statement ();
6116 goto duplicate_main
;
6118 prog_locus
= gfc_current_locus
;
6120 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
6121 main_program_symbol (gfc_current_ns
, gfc_new_block
->name
);
6122 accept_statement (st
);
6123 add_global_program ();
6124 parse_progunit (ST_NONE
);
6128 add_global_procedure (true);
6129 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
6130 accept_statement (st
);
6131 parse_progunit (ST_NONE
);
6135 add_global_procedure (false);
6136 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
6137 accept_statement (st
);
6138 parse_progunit (ST_NONE
);
6142 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
6143 accept_statement (st
);
6144 parse_block_data ();
6148 push_state (&s
, COMP_MODULE
, gfc_new_block
);
6149 accept_statement (st
);
6151 gfc_get_errors (NULL
, &errors_before
);
6156 push_state (&s
, COMP_SUBMODULE
, gfc_new_block
);
6157 accept_statement (st
);
6159 gfc_get_errors (NULL
, &errors_before
);
6163 /* Anything else starts a nameless main program block. */
6166 goto duplicate_main
;
6168 prog_locus
= gfc_current_locus
;
6170 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
6171 main_program_symbol (gfc_current_ns
, "MAIN__");
6172 parse_progunit (st
);
6176 /* Handle the non-program units. */
6177 gfc_current_ns
->code
= s
.head
;
6179 gfc_resolve (gfc_current_ns
);
6181 /* Dump the parse tree if requested. */
6182 if (flag_dump_fortran_original
)
6183 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6185 gfc_get_errors (NULL
, &errors
);
6186 if (s
.state
== COMP_MODULE
|| s
.state
== COMP_SUBMODULE
)
6188 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
6189 gfc_current_ns
->derived_types
= gfc_derived_types
;
6190 gfc_derived_types
= NULL
;
6196 gfc_generate_code (gfc_current_ns
);
6204 /* The main program and non-contained procedures are put
6205 in the global namespace list, so that they can be processed
6206 later and all their interfaces resolved. */
6207 gfc_current_ns
->code
= s
.head
;
6210 for (; next
->sibling
; next
= next
->sibling
)
6212 next
->sibling
= gfc_current_ns
;
6215 gfc_global_ns_list
= gfc_current_ns
;
6217 next
= gfc_current_ns
;
6223 /* Do the resolution. */
6224 resolve_all_program_units (gfc_global_ns_list
);
6226 /* Do the parse tree dump. */
6227 gfc_current_ns
= flag_dump_fortran_original
? gfc_global_ns_list
: NULL
;
6229 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6230 if (!gfc_current_ns
->proc_name
6231 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6233 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6234 fputs ("------------------------------------------\n\n", stdout
);
6237 /* Do the translation. */
6238 translate_all_program_units (gfc_global_ns_list
);
6240 gfc_end_source_files ();
6244 /* If we see a duplicate main program, shut down. If the second
6245 instance is an implied main program, i.e. data decls or executable
6246 statements, we're in for lots of errors. */
6247 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
6248 reject_statement ();
6253 /* Return true if this state data represents an OpenACC region. */
6255 is_oacc (gfc_state_data
*sd
)
6257 switch (sd
->construct
->op
)
6259 case EXEC_OACC_PARALLEL_LOOP
:
6260 case EXEC_OACC_PARALLEL
:
6261 case EXEC_OACC_KERNELS_LOOP
:
6262 case EXEC_OACC_KERNELS
:
6263 case EXEC_OACC_DATA
:
6264 case EXEC_OACC_HOST_DATA
:
6265 case EXEC_OACC_LOOP
:
6266 case EXEC_OACC_UPDATE
:
6267 case EXEC_OACC_WAIT
:
6268 case EXEC_OACC_CACHE
:
6269 case EXEC_OACC_ENTER_DATA
:
6270 case EXEC_OACC_EXIT_DATA
:
6271 case EXEC_OACC_ATOMIC
:
6272 case EXEC_OACC_ROUTINE
: