2 Copyright (C) 2000-2017 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_equiv
= gfc_current_ns
->equiv
;
120 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
121 last_was_use_stmt
= false;
125 /* Figure out what the next statement is, (mostly) regardless of
126 proper ordering. The do...while(0) is there to prevent if/else
129 #define match(keyword, subr, st) \
131 if (match_word (keyword, subr, &old_locus) == MATCH_YES) \
134 undo_new_statement (); \
138 /* This is a specialist version of decode_statement that is used
139 for the specification statements in a function, whose
140 characteristics are deferred into the specification statements.
141 eg.: INTEGER (king = mykind) foo ()
142 USE mymodule, ONLY mykind.....
143 The KIND parameter needs a return after USE or IMPORT, whereas
144 derived type declarations can occur anywhere, up the executable
145 block. ST_GET_FCN_CHARACTERISTICS is returned when we have run
146 out of the correct kind of specification statements. */
148 decode_specification_statement (void)
154 if (gfc_match_eos () == MATCH_YES
)
157 old_locus
= gfc_current_locus
;
159 if (match_word ("use", gfc_match_use
, &old_locus
) == MATCH_YES
)
161 last_was_use_stmt
= true;
166 undo_new_statement ();
167 if (last_was_use_stmt
)
171 match ("import", gfc_match_import
, ST_IMPORT
);
173 if (gfc_current_block ()->result
->ts
.type
!= BT_DERIVED
)
176 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
177 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
178 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
180 /* General statement matching: Instead of testing every possible
181 statement, we eliminate most possibilities by peeking at the
184 c
= gfc_peek_ascii_char ();
189 match ("abstract% interface", gfc_match_abstract_interface
,
191 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
192 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
193 match ("automatic", gfc_match_automatic
, ST_ATTR_DECL
);
197 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
201 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
202 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
206 match ("data", gfc_match_data
, ST_DATA
);
207 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
211 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
212 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
213 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
214 match ("external", gfc_match_external
, ST_ATTR_DECL
);
218 match ("format", gfc_match_format
, ST_FORMAT
);
225 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
226 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
227 match ("interface", gfc_match_interface
, ST_INTERFACE
);
228 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
229 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
236 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
240 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
244 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
245 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
246 if (gfc_match_private (&st
) == MATCH_YES
)
248 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
249 if (gfc_match_public (&st
) == MATCH_YES
)
251 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
258 match ("save", gfc_match_save
, ST_ATTR_DECL
);
259 match ("static", gfc_match_static
, ST_ATTR_DECL
);
260 match ("structure", gfc_match_structure_decl
, ST_STRUCTURE_DECL
);
264 match ("target", gfc_match_target
, ST_ATTR_DECL
);
265 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
272 match ("value", gfc_match_value
, ST_ATTR_DECL
);
273 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
280 /* This is not a specification statement. See if any of the matchers
281 has stored an error message of some sort. */
285 gfc_buffer_error (false);
286 gfc_current_locus
= old_locus
;
288 return ST_GET_FCN_CHARACTERISTICS
;
291 static bool in_specification_block
;
293 /* This is the primary 'decode_statement'. */
295 decode_statement (void)
302 gfc_enforce_clean_symbol_state ();
304 gfc_clear_error (); /* Clear any pending errors. */
305 gfc_clear_warning (); /* Clear any pending warnings. */
307 gfc_matching_function
= false;
309 if (gfc_match_eos () == MATCH_YES
)
312 if (gfc_current_state () == COMP_FUNCTION
313 && gfc_current_block ()->result
->ts
.kind
== -1)
314 return decode_specification_statement ();
316 old_locus
= gfc_current_locus
;
318 c
= gfc_peek_ascii_char ();
322 if (match_word ("use", gfc_match_use
, &old_locus
) == MATCH_YES
)
324 last_was_use_stmt
= true;
328 undo_new_statement ();
331 if (last_was_use_stmt
)
334 /* Try matching a data declaration or function declaration. The
335 input "REALFUNCTIONA(N)" can mean several things in different
336 contexts, so it (and its relatives) get special treatment. */
338 if (gfc_current_state () == COMP_NONE
339 || gfc_current_state () == COMP_INTERFACE
340 || gfc_current_state () == COMP_CONTAINS
)
342 gfc_matching_function
= true;
343 m
= gfc_match_function_decl ();
346 else if (m
== MATCH_ERROR
)
350 gfc_current_locus
= old_locus
;
352 gfc_matching_function
= false;
354 /* Legacy parameter statements are ambiguous with assignments so try parameter
356 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
358 /* Match statements whose error messages are meant to be overwritten
359 by something better. */
361 match (NULL
, gfc_match_assignment
, ST_ASSIGNMENT
);
362 match (NULL
, gfc_match_pointer_assignment
, ST_POINTER_ASSIGNMENT
);
364 if (in_specification_block
)
366 m
= match_word (NULL
, gfc_match_st_function
, &old_locus
);
368 return ST_STATEMENT_FUNCTION
;
371 if (!(in_specification_block
&& m
== MATCH_ERROR
))
373 match (NULL
, gfc_match_ptr_fcn_assign
, ST_ASSIGNMENT
);
376 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
377 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
379 /* Try to match a subroutine statement, which has the same optional
380 prefixes that functions can have. */
382 if (gfc_match_subroutine () == MATCH_YES
)
383 return ST_SUBROUTINE
;
385 gfc_current_locus
= old_locus
;
387 if (gfc_match_submod_proc () == MATCH_YES
)
389 if (gfc_new_block
->attr
.subroutine
)
390 return ST_SUBROUTINE
;
391 else if (gfc_new_block
->attr
.function
)
395 gfc_current_locus
= old_locus
;
397 /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
398 statements, which might begin with a block label. The match functions for
399 these statements are unusual in that their keyword is not seen before
400 the matcher is called. */
402 if (gfc_match_if (&st
) == MATCH_YES
)
405 gfc_current_locus
= old_locus
;
407 if (gfc_match_where (&st
) == MATCH_YES
)
410 gfc_current_locus
= old_locus
;
412 if (gfc_match_forall (&st
) == MATCH_YES
)
415 gfc_current_locus
= old_locus
;
417 /* Try to match TYPE as an alias for PRINT. */
418 if (gfc_match_type (&st
) == MATCH_YES
)
421 gfc_current_locus
= old_locus
;
423 match (NULL
, gfc_match_do
, ST_DO
);
424 match (NULL
, gfc_match_block
, ST_BLOCK
);
425 match (NULL
, gfc_match_associate
, ST_ASSOCIATE
);
426 match (NULL
, gfc_match_critical
, ST_CRITICAL
);
427 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
428 match (NULL
, gfc_match_select_type
, ST_SELECT_TYPE
);
430 /* General statement matching: Instead of testing every possible
431 statement, we eliminate most possibilities by peeking at the
437 match ("abstract% interface", gfc_match_abstract_interface
,
439 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
440 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
441 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
442 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
443 match ("automatic", gfc_match_automatic
, ST_ATTR_DECL
);
447 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
448 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
449 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
453 match ("call", gfc_match_call
, ST_CALL
);
454 match ("close", gfc_match_close
, ST_CLOSE
);
455 match ("continue", gfc_match_continue
, ST_CONTINUE
);
456 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
457 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
458 match ("case", gfc_match_case
, ST_CASE
);
459 match ("common", gfc_match_common
, ST_COMMON
);
460 match ("contains", gfc_match_eos
, ST_CONTAINS
);
461 match ("class", gfc_match_class_is
, ST_CLASS_IS
);
462 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
466 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
467 match ("data", gfc_match_data
, ST_DATA
);
468 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
472 match ("end file", gfc_match_endfile
, ST_END_FILE
);
473 match ("exit", gfc_match_exit
, ST_EXIT
);
474 match ("else", gfc_match_else
, ST_ELSE
);
475 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
476 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
477 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
);
478 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
480 if (gfc_match_end (&st
) == MATCH_YES
)
483 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
484 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
485 match ("external", gfc_match_external
, ST_ATTR_DECL
);
486 match ("event post", gfc_match_event_post
, ST_EVENT_POST
);
487 match ("event wait", gfc_match_event_wait
, ST_EVENT_WAIT
);
491 match ("final", gfc_match_final_decl
, ST_FINAL
);
492 match ("flush", gfc_match_flush
, ST_FLUSH
);
493 match ("format", gfc_match_format
, ST_FORMAT
);
497 match ("generic", gfc_match_generic
, ST_GENERIC
);
498 match ("go to", gfc_match_goto
, ST_GOTO
);
502 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
503 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
504 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
505 match ("import", gfc_match_import
, ST_IMPORT
);
506 match ("interface", gfc_match_interface
, ST_INTERFACE
);
507 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
508 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
512 match ("lock", gfc_match_lock
, ST_LOCK
);
516 match ("map", gfc_match_map
, ST_MAP
);
517 match ("module% procedure", gfc_match_modproc
, ST_MODULE_PROC
);
518 match ("module", gfc_match_module
, ST_MODULE
);
522 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
523 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
527 match ("open", gfc_match_open
, ST_OPEN
);
528 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
532 match ("print", gfc_match_print
, ST_WRITE
);
533 match ("pause", gfc_match_pause
, ST_PAUSE
);
534 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
535 if (gfc_match_private (&st
) == MATCH_YES
)
537 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
538 match ("program", gfc_match_program
, ST_PROGRAM
);
539 if (gfc_match_public (&st
) == MATCH_YES
)
541 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
545 match ("read", gfc_match_read
, ST_READ
);
546 match ("return", gfc_match_return
, ST_RETURN
);
547 match ("rewind", gfc_match_rewind
, ST_REWIND
);
551 match ("structure", gfc_match_structure_decl
, ST_STRUCTURE_DECL
);
552 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
553 match ("stop", gfc_match_stop
, ST_STOP
);
554 match ("save", gfc_match_save
, ST_ATTR_DECL
);
555 match ("static", gfc_match_static
, ST_ATTR_DECL
);
556 match ("submodule", gfc_match_submodule
, ST_SUBMODULE
);
557 match ("sync all", gfc_match_sync_all
, ST_SYNC_ALL
);
558 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
559 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
563 match ("target", gfc_match_target
, ST_ATTR_DECL
);
564 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
565 match ("type is", gfc_match_type_is
, ST_TYPE_IS
);
569 match ("union", gfc_match_union
, ST_UNION
);
570 match ("unlock", gfc_match_unlock
, ST_UNLOCK
);
574 match ("value", gfc_match_value
, ST_ATTR_DECL
);
575 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
579 match ("wait", gfc_match_wait
, ST_WAIT
);
580 match ("write", gfc_match_write
, ST_WRITE
);
584 /* All else has failed, so give up. See if any of the matchers has
585 stored an error message of some sort. */
587 if (!gfc_error_check ())
588 gfc_error_now ("Unclassifiable statement at %C");
592 gfc_error_recovery ();
597 /* Like match and if spec_only, goto do_spec_only without actually
599 #define matcha(keyword, subr, st) \
601 if (spec_only && gfc_match (keyword) == MATCH_YES) \
603 else if (match_word (keyword, subr, &old_locus) \
607 undo_new_statement (); \
611 decode_oacc_directive (void)
615 bool spec_only
= false;
617 gfc_enforce_clean_symbol_state ();
619 gfc_clear_error (); /* Clear any pending errors. */
620 gfc_clear_warning (); /* Clear any pending warnings. */
624 gfc_error_now ("OpenACC directives at %C may not appear in PURE "
626 gfc_error_recovery ();
630 if (gfc_current_state () == COMP_FUNCTION
631 && gfc_current_block ()->result
->ts
.kind
== -1)
634 gfc_unset_implicit_pure (NULL
);
636 old_locus
= gfc_current_locus
;
638 /* General OpenACC directive matching: Instead of testing every possible
639 statement, we eliminate most possibilities by peeking at the
642 c
= gfc_peek_ascii_char ();
647 matcha ("atomic", gfc_match_oacc_atomic
, ST_OACC_ATOMIC
);
650 matcha ("cache", gfc_match_oacc_cache
, ST_OACC_CACHE
);
653 matcha ("data", gfc_match_oacc_data
, ST_OACC_DATA
);
654 match ("declare", gfc_match_oacc_declare
, ST_OACC_DECLARE
);
657 matcha ("end atomic", gfc_match_omp_eos
, ST_OACC_END_ATOMIC
);
658 matcha ("end data", gfc_match_omp_eos
, ST_OACC_END_DATA
);
659 matcha ("end host_data", gfc_match_omp_eos
, ST_OACC_END_HOST_DATA
);
660 matcha ("end kernels loop", gfc_match_omp_eos
, ST_OACC_END_KERNELS_LOOP
);
661 matcha ("end kernels", gfc_match_omp_eos
, ST_OACC_END_KERNELS
);
662 matcha ("end loop", gfc_match_omp_eos
, ST_OACC_END_LOOP
);
663 matcha ("end parallel loop", gfc_match_omp_eos
,
664 ST_OACC_END_PARALLEL_LOOP
);
665 matcha ("end parallel", gfc_match_omp_eos
, ST_OACC_END_PARALLEL
);
666 matcha ("enter data", gfc_match_oacc_enter_data
, ST_OACC_ENTER_DATA
);
667 matcha ("exit data", gfc_match_oacc_exit_data
, ST_OACC_EXIT_DATA
);
670 matcha ("host_data", gfc_match_oacc_host_data
, ST_OACC_HOST_DATA
);
673 matcha ("parallel loop", gfc_match_oacc_parallel_loop
,
674 ST_OACC_PARALLEL_LOOP
);
675 matcha ("parallel", gfc_match_oacc_parallel
, ST_OACC_PARALLEL
);
678 matcha ("kernels loop", gfc_match_oacc_kernels_loop
,
679 ST_OACC_KERNELS_LOOP
);
680 matcha ("kernels", gfc_match_oacc_kernels
, ST_OACC_KERNELS
);
683 matcha ("loop", gfc_match_oacc_loop
, ST_OACC_LOOP
);
686 match ("routine", gfc_match_oacc_routine
, ST_OACC_ROUTINE
);
689 matcha ("update", gfc_match_oacc_update
, ST_OACC_UPDATE
);
692 matcha ("wait", gfc_match_oacc_wait
, ST_OACC_WAIT
);
696 /* Directive not found or stored an error message.
697 Check and give up. */
699 if (gfc_error_check () == 0)
700 gfc_error_now ("Unclassifiable OpenACC directive at %C");
704 gfc_error_recovery ();
711 gfc_buffer_error (false);
712 gfc_current_locus
= old_locus
;
713 return ST_GET_FCN_CHARACTERISTICS
;
716 /* Like match, but set a flag simd_matched if keyword matched
717 and if spec_only, goto do_spec_only without actually matching. */
718 #define matchs(keyword, subr, st) \
720 if (spec_only && gfc_match (keyword) == MATCH_YES) \
722 if (match_word_omp_simd (keyword, subr, &old_locus, \
723 &simd_matched) == MATCH_YES) \
726 undo_new_statement (); \
729 /* Like match, but don't match anything if not -fopenmp
730 and if spec_only, goto do_spec_only without actually matching. */
731 #define matcho(keyword, subr, st) \
735 else if (spec_only && gfc_match (keyword) == MATCH_YES) \
737 else if (match_word (keyword, subr, &old_locus) \
741 undo_new_statement (); \
744 /* Like match, but set a flag simd_matched if keyword matched. */
745 #define matchds(keyword, subr, st) \
747 if (match_word_omp_simd (keyword, subr, &old_locus, \
748 &simd_matched) == MATCH_YES) \
751 undo_new_statement (); \
754 /* Like match, but don't match anything if not -fopenmp. */
755 #define matchdo(keyword, subr, st) \
759 else if (match_word (keyword, subr, &old_locus) \
763 undo_new_statement (); \
767 decode_omp_directive (void)
771 bool simd_matched
= false;
772 bool spec_only
= false;
774 gfc_enforce_clean_symbol_state ();
776 gfc_clear_error (); /* Clear any pending errors. */
777 gfc_clear_warning (); /* Clear any pending warnings. */
781 gfc_error_now ("OpenMP directives at %C may not appear in PURE "
782 "or ELEMENTAL procedures");
783 gfc_error_recovery ();
787 if (gfc_current_state () == COMP_FUNCTION
788 && gfc_current_block ()->result
->ts
.kind
== -1)
791 gfc_unset_implicit_pure (NULL
);
793 old_locus
= gfc_current_locus
;
795 /* General OpenMP directive matching: Instead of testing every possible
796 statement, we eliminate most possibilities by peeking at the
799 c
= gfc_peek_ascii_char ();
801 /* match is for directives that should be recognized only if
802 -fopenmp, matchs for directives that should be recognized
803 if either -fopenmp or -fopenmp-simd. */
807 matcho ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
810 matcho ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
813 matcho ("cancellation% point", gfc_match_omp_cancellation_point
,
814 ST_OMP_CANCELLATION_POINT
);
815 matcho ("cancel", gfc_match_omp_cancel
, ST_OMP_CANCEL
);
816 matcho ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
819 matchds ("declare reduction", gfc_match_omp_declare_reduction
,
820 ST_OMP_DECLARE_REDUCTION
);
821 matchds ("declare simd", gfc_match_omp_declare_simd
,
822 ST_OMP_DECLARE_SIMD
);
823 matchdo ("declare target", gfc_match_omp_declare_target
,
824 ST_OMP_DECLARE_TARGET
);
825 matchs ("distribute parallel do simd",
826 gfc_match_omp_distribute_parallel_do_simd
,
827 ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
);
828 matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do
,
829 ST_OMP_DISTRIBUTE_PARALLEL_DO
);
830 matchs ("distribute simd", gfc_match_omp_distribute_simd
,
831 ST_OMP_DISTRIBUTE_SIMD
);
832 matcho ("distribute", gfc_match_omp_distribute
, ST_OMP_DISTRIBUTE
);
833 matchs ("do simd", gfc_match_omp_do_simd
, ST_OMP_DO_SIMD
);
834 matcho ("do", gfc_match_omp_do
, ST_OMP_DO
);
837 matcho ("end atomic", gfc_match_omp_eos
, ST_OMP_END_ATOMIC
);
838 matcho ("end critical", gfc_match_omp_end_critical
, ST_OMP_END_CRITICAL
);
839 matchs ("end distribute parallel do simd", gfc_match_omp_eos
,
840 ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
);
841 matcho ("end distribute parallel do", gfc_match_omp_eos
,
842 ST_OMP_END_DISTRIBUTE_PARALLEL_DO
);
843 matchs ("end distribute simd", gfc_match_omp_eos
,
844 ST_OMP_END_DISTRIBUTE_SIMD
);
845 matcho ("end distribute", gfc_match_omp_eos
, ST_OMP_END_DISTRIBUTE
);
846 matchs ("end do simd", gfc_match_omp_end_nowait
, ST_OMP_END_DO_SIMD
);
847 matcho ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
848 matchs ("end simd", gfc_match_omp_eos
, ST_OMP_END_SIMD
);
849 matcho ("end master", gfc_match_omp_eos
, ST_OMP_END_MASTER
);
850 matcho ("end ordered", gfc_match_omp_eos
, ST_OMP_END_ORDERED
);
851 matchs ("end parallel do simd", gfc_match_omp_eos
,
852 ST_OMP_END_PARALLEL_DO_SIMD
);
853 matcho ("end parallel do", gfc_match_omp_eos
, ST_OMP_END_PARALLEL_DO
);
854 matcho ("end parallel sections", gfc_match_omp_eos
,
855 ST_OMP_END_PARALLEL_SECTIONS
);
856 matcho ("end parallel workshare", gfc_match_omp_eos
,
857 ST_OMP_END_PARALLEL_WORKSHARE
);
858 matcho ("end parallel", gfc_match_omp_eos
, ST_OMP_END_PARALLEL
);
859 matcho ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
860 matcho ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
861 matcho ("end target data", gfc_match_omp_eos
, ST_OMP_END_TARGET_DATA
);
862 matchs ("end target parallel do simd", gfc_match_omp_eos
,
863 ST_OMP_END_TARGET_PARALLEL_DO_SIMD
);
864 matcho ("end target parallel do", gfc_match_omp_eos
,
865 ST_OMP_END_TARGET_PARALLEL_DO
);
866 matcho ("end target parallel", gfc_match_omp_eos
,
867 ST_OMP_END_TARGET_PARALLEL
);
868 matchs ("end target simd", gfc_match_omp_eos
, ST_OMP_END_TARGET_SIMD
);
869 matchs ("end target teams distribute parallel do simd",
871 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
872 matcho ("end target teams distribute parallel do", gfc_match_omp_eos
,
873 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
874 matchs ("end target teams distribute simd", gfc_match_omp_eos
,
875 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
);
876 matcho ("end target teams distribute", gfc_match_omp_eos
,
877 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
);
878 matcho ("end target teams", gfc_match_omp_eos
, ST_OMP_END_TARGET_TEAMS
);
879 matcho ("end target", gfc_match_omp_eos
, ST_OMP_END_TARGET
);
880 matcho ("end taskgroup", gfc_match_omp_eos
, ST_OMP_END_TASKGROUP
);
881 matchs ("end taskloop simd", gfc_match_omp_eos
,
882 ST_OMP_END_TASKLOOP_SIMD
);
883 matcho ("end taskloop", gfc_match_omp_eos
, ST_OMP_END_TASKLOOP
);
884 matcho ("end task", gfc_match_omp_eos
, ST_OMP_END_TASK
);
885 matchs ("end teams distribute parallel do simd", gfc_match_omp_eos
,
886 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
887 matcho ("end teams distribute parallel do", gfc_match_omp_eos
,
888 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
);
889 matchs ("end teams distribute simd", gfc_match_omp_eos
,
890 ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
);
891 matcho ("end teams distribute", gfc_match_omp_eos
,
892 ST_OMP_END_TEAMS_DISTRIBUTE
);
893 matcho ("end teams", gfc_match_omp_eos
, ST_OMP_END_TEAMS
);
894 matcho ("end workshare", gfc_match_omp_end_nowait
,
895 ST_OMP_END_WORKSHARE
);
898 matcho ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
901 matcho ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
904 if (flag_openmp
&& gfc_match ("ordered depend (") == MATCH_YES
)
906 gfc_current_locus
= old_locus
;
907 matcho ("ordered", gfc_match_omp_ordered_depend
,
908 ST_OMP_ORDERED_DEPEND
);
911 matcho ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
914 matchs ("parallel do simd", gfc_match_omp_parallel_do_simd
,
915 ST_OMP_PARALLEL_DO_SIMD
);
916 matcho ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
917 matcho ("parallel sections", gfc_match_omp_parallel_sections
,
918 ST_OMP_PARALLEL_SECTIONS
);
919 matcho ("parallel workshare", gfc_match_omp_parallel_workshare
,
920 ST_OMP_PARALLEL_WORKSHARE
);
921 matcho ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
924 matcho ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
925 matcho ("section", gfc_match_omp_eos
, ST_OMP_SECTION
);
926 matchs ("simd", gfc_match_omp_simd
, ST_OMP_SIMD
);
927 matcho ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
930 matcho ("target data", gfc_match_omp_target_data
, ST_OMP_TARGET_DATA
);
931 matcho ("target enter data", gfc_match_omp_target_enter_data
,
932 ST_OMP_TARGET_ENTER_DATA
);
933 matcho ("target exit data", gfc_match_omp_target_exit_data
,
934 ST_OMP_TARGET_EXIT_DATA
);
935 matchs ("target parallel do simd", gfc_match_omp_target_parallel_do_simd
,
936 ST_OMP_TARGET_PARALLEL_DO_SIMD
);
937 matcho ("target parallel do", gfc_match_omp_target_parallel_do
,
938 ST_OMP_TARGET_PARALLEL_DO
);
939 matcho ("target parallel", gfc_match_omp_target_parallel
,
940 ST_OMP_TARGET_PARALLEL
);
941 matchs ("target simd", gfc_match_omp_target_simd
, ST_OMP_TARGET_SIMD
);
942 matchs ("target teams distribute parallel do simd",
943 gfc_match_omp_target_teams_distribute_parallel_do_simd
,
944 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
945 matcho ("target teams distribute parallel do",
946 gfc_match_omp_target_teams_distribute_parallel_do
,
947 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
948 matchs ("target teams distribute simd",
949 gfc_match_omp_target_teams_distribute_simd
,
950 ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
);
951 matcho ("target teams distribute", gfc_match_omp_target_teams_distribute
,
952 ST_OMP_TARGET_TEAMS_DISTRIBUTE
);
953 matcho ("target teams", gfc_match_omp_target_teams
, ST_OMP_TARGET_TEAMS
);
954 matcho ("target update", gfc_match_omp_target_update
,
955 ST_OMP_TARGET_UPDATE
);
956 matcho ("target", gfc_match_omp_target
, ST_OMP_TARGET
);
957 matcho ("taskgroup", gfc_match_omp_taskgroup
, ST_OMP_TASKGROUP
);
958 matchs ("taskloop simd", gfc_match_omp_taskloop_simd
,
959 ST_OMP_TASKLOOP_SIMD
);
960 matcho ("taskloop", gfc_match_omp_taskloop
, ST_OMP_TASKLOOP
);
961 matcho ("taskwait", gfc_match_omp_taskwait
, ST_OMP_TASKWAIT
);
962 matcho ("taskyield", gfc_match_omp_taskyield
, ST_OMP_TASKYIELD
);
963 matcho ("task", gfc_match_omp_task
, ST_OMP_TASK
);
964 matchs ("teams distribute parallel do simd",
965 gfc_match_omp_teams_distribute_parallel_do_simd
,
966 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
967 matcho ("teams distribute parallel do",
968 gfc_match_omp_teams_distribute_parallel_do
,
969 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
);
970 matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd
,
971 ST_OMP_TEAMS_DISTRIBUTE_SIMD
);
972 matcho ("teams distribute", gfc_match_omp_teams_distribute
,
973 ST_OMP_TEAMS_DISTRIBUTE
);
974 matcho ("teams", gfc_match_omp_teams
, ST_OMP_TEAMS
);
975 matchdo ("threadprivate", gfc_match_omp_threadprivate
,
976 ST_OMP_THREADPRIVATE
);
979 matcho ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
983 /* All else has failed, so give up. See if any of the matchers has
984 stored an error message of some sort. Don't error out if
985 not -fopenmp and simd_matched is false, i.e. if a directive other
986 than one marked with match has been seen. */
988 if (flag_openmp
|| simd_matched
)
990 if (!gfc_error_check ())
991 gfc_error_now ("Unclassifiable OpenMP directive at %C");
996 gfc_error_recovery ();
1001 reject_statement ();
1003 gfc_buffer_error (false);
1004 gfc_current_locus
= old_locus
;
1005 return ST_GET_FCN_CHARACTERISTICS
;
1008 static gfc_statement
1009 decode_gcc_attribute (void)
1013 gfc_enforce_clean_symbol_state ();
1015 gfc_clear_error (); /* Clear any pending errors. */
1016 gfc_clear_warning (); /* Clear any pending warnings. */
1017 old_locus
= gfc_current_locus
;
1019 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
1021 /* All else has failed, so give up. See if any of the matchers has
1022 stored an error message of some sort. */
1024 if (!gfc_error_check ())
1025 gfc_error_now ("Unclassifiable GCC directive at %C");
1027 reject_statement ();
1029 gfc_error_recovery ();
1036 /* Assert next length characters to be equal to token in free form. */
1039 verify_token_free (const char* token
, int length
, bool last_was_use_stmt
)
1044 c
= gfc_next_ascii_char ();
1045 for (i
= 0; i
< length
; i
++, c
= gfc_next_ascii_char ())
1046 gcc_assert (c
== token
[i
]);
1048 gcc_assert (gfc_is_whitespace(c
));
1049 gfc_gobble_whitespace ();
1050 if (last_was_use_stmt
)
1054 /* Get the next statement in free form source. */
1056 static gfc_statement
1063 at_bol
= gfc_at_bol ();
1064 gfc_gobble_whitespace ();
1066 c
= gfc_peek_ascii_char ();
1072 /* Found a statement label? */
1073 m
= gfc_match_st_label (&gfc_statement_label
);
1075 d
= gfc_peek_ascii_char ();
1076 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
1078 gfc_match_small_literal_int (&i
, &cnt
);
1081 gfc_error_now ("Too many digits in statement label at %C");
1084 gfc_error_now ("Zero is not a valid statement label at %C");
1087 c
= gfc_next_ascii_char ();
1090 if (!gfc_is_whitespace (c
))
1091 gfc_error_now ("Non-numeric character in statement label at %C");
1097 label_locus
= gfc_current_locus
;
1099 gfc_gobble_whitespace ();
1101 if (at_bol
&& gfc_peek_ascii_char () == ';')
1103 gfc_error_now ("Semicolon at %C needs to be preceded by "
1105 gfc_next_ascii_char (); /* Eat up the semicolon. */
1109 if (gfc_match_eos () == MATCH_YES
)
1110 gfc_error_now ("Statement label without statement at %L",
1116 /* Comments have already been skipped by the time we get here,
1117 except for GCC attributes and OpenMP/OpenACC directives. */
1119 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
1120 c
= gfc_peek_ascii_char ();
1126 c
= gfc_next_ascii_char ();
1127 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
1128 gcc_assert (c
== "gcc$"[i
]);
1130 gfc_gobble_whitespace ();
1131 return decode_gcc_attribute ();
1136 /* Since both OpenMP and OpenACC directives starts with
1137 !$ character sequence, we must check all flags combinations */
1138 if ((flag_openmp
|| flag_openmp_simd
)
1141 verify_token_free ("$omp", 4, last_was_use_stmt
);
1142 return decode_omp_directive ();
1144 else if ((flag_openmp
|| flag_openmp_simd
)
1147 gfc_next_ascii_char (); /* Eat up dollar character */
1148 c
= gfc_peek_ascii_char ();
1152 verify_token_free ("omp", 3, last_was_use_stmt
);
1153 return decode_omp_directive ();
1157 verify_token_free ("acc", 3, last_was_use_stmt
);
1158 return decode_oacc_directive ();
1161 else if (flag_openacc
)
1163 verify_token_free ("$acc", 4, last_was_use_stmt
);
1164 return decode_oacc_directive ();
1170 if (at_bol
&& c
== ';')
1172 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1173 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1175 gfc_next_ascii_char (); /* Eat up the semicolon. */
1179 return decode_statement ();
1182 /* Assert next length characters to be equal to token in fixed form. */
1185 verify_token_fixed (const char *token
, int length
, bool last_was_use_stmt
)
1188 char c
= gfc_next_char_literal (NONSTRING
);
1190 for (i
= 0; i
< length
; i
++, c
= gfc_next_char_literal (NONSTRING
))
1191 gcc_assert ((char) gfc_wide_tolower (c
) == token
[i
]);
1193 if (c
!= ' ' && c
!= '0')
1195 gfc_buffer_error (false);
1196 gfc_error ("Bad continuation line at %C");
1199 if (last_was_use_stmt
)
1205 /* Get the next statement in fixed-form source. */
1207 static gfc_statement
1210 int label
, digit_flag
, i
;
1215 return decode_statement ();
1217 /* Skip past the current label field, parsing a statement label if
1218 one is there. This is a weird number parser, since the number is
1219 contained within five columns and can have any kind of embedded
1220 spaces. We also check for characters that make the rest of the
1226 for (i
= 0; i
< 5; i
++)
1228 c
= gfc_next_char_literal (NONSTRING
);
1245 label
= label
* 10 + ((unsigned char) c
- '0');
1246 label_locus
= gfc_current_locus
;
1250 /* Comments have already been skipped by the time we get
1251 here, except for GCC attributes and OpenMP directives. */
1254 c
= gfc_next_char_literal (NONSTRING
);
1256 if (TOLOWER (c
) == 'g')
1258 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
1259 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
1261 return decode_gcc_attribute ();
1265 if ((flag_openmp
|| flag_openmp_simd
)
1268 if (!verify_token_fixed ("omp", 3, last_was_use_stmt
))
1270 return decode_omp_directive ();
1272 else if ((flag_openmp
|| flag_openmp_simd
)
1275 c
= gfc_next_char_literal(NONSTRING
);
1276 if (c
== 'o' || c
== 'O')
1278 if (!verify_token_fixed ("mp", 2, last_was_use_stmt
))
1280 return decode_omp_directive ();
1282 else if (c
== 'a' || c
== 'A')
1284 if (!verify_token_fixed ("cc", 2, last_was_use_stmt
))
1286 return decode_oacc_directive ();
1289 else if (flag_openacc
)
1291 if (!verify_token_fixed ("acc", 3, last_was_use_stmt
))
1293 return decode_oacc_directive ();
1298 /* Comments have already been skipped by the time we get
1299 here so don't bother checking for them. */
1302 gfc_buffer_error (false);
1303 gfc_error ("Non-numeric character in statement label at %C");
1311 gfc_warning_now (0, "Zero is not a valid statement label at %C");
1314 /* We've found a valid statement label. */
1315 gfc_statement_label
= gfc_get_st_label (label
);
1319 /* Since this line starts a statement, it cannot be a continuation
1320 of a previous statement. If we see something here besides a
1321 space or zero, it must be a bad continuation line. */
1323 c
= gfc_next_char_literal (NONSTRING
);
1327 if (c
!= ' ' && c
!= '0')
1329 gfc_buffer_error (false);
1330 gfc_error ("Bad continuation line at %C");
1334 /* Now that we've taken care of the statement label columns, we have
1335 to make sure that the first nonblank character is not a '!'. If
1336 it is, the rest of the line is a comment. */
1340 loc
= gfc_current_locus
;
1341 c
= gfc_next_char_literal (NONSTRING
);
1343 while (gfc_is_whitespace (c
));
1347 gfc_current_locus
= loc
;
1352 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1353 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1354 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1359 if (gfc_match_eos () == MATCH_YES
)
1362 /* At this point, we've got a nonblank statement to parse. */
1363 return decode_statement ();
1367 gfc_error_now ("Statement label without statement at %L", &label_locus
);
1369 gfc_current_locus
.lb
->truncated
= 0;
1370 gfc_advance_line ();
1375 /* Return the next non-ST_NONE statement to the caller. We also worry
1376 about including files and the ends of include files at this stage. */
1378 static gfc_statement
1379 next_statement (void)
1384 gfc_enforce_clean_symbol_state ();
1386 gfc_new_block
= NULL
;
1388 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1389 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
1392 gfc_statement_label
= NULL
;
1393 gfc_buffer_error (true);
1396 gfc_advance_line ();
1398 gfc_skip_comments ();
1406 if (gfc_define_undef_line ())
1409 old_locus
= gfc_current_locus
;
1411 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1417 gfc_buffer_error (false);
1419 if (st
== ST_GET_FCN_CHARACTERISTICS
)
1421 if (gfc_statement_label
!= NULL
)
1423 gfc_free_st_label (gfc_statement_label
);
1424 gfc_statement_label
= NULL
;
1426 gfc_current_locus
= old_locus
;
1430 check_statement_label (st
);
1436 /****************************** Parser ***********************************/
1438 /* The parser subroutines are of type 'try' that fail if the file ends
1441 /* Macros that expand to case-labels for various classes of
1442 statements. Start with executable statements that directly do
1445 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1446 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1447 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1448 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1449 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1450 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1451 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1452 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1453 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1454 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
1455 case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
1456 case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: \
1457 case ST_ERROR_STOP: case ST_SYNC_ALL: \
1458 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1459 case ST_EVENT_POST: case ST_EVENT_WAIT: \
1460 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1461 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1463 /* Statements that mark other executable statements. */
1465 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1466 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1467 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1468 case ST_OMP_PARALLEL: \
1469 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1470 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
1471 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1472 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1473 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1474 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1475 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1476 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1477 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1478 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1479 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1480 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1481 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1482 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1483 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1484 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1485 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \
1486 case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \
1487 case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
1489 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1490 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
1491 case ST_OACC_KERNELS_LOOP: case ST_OACC_ATOMIC
1493 /* Declaration statements */
1495 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1496 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1497 case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE: case ST_OACC_ROUTINE: \
1498 case ST_OACC_DECLARE
1500 /* OpenMP declaration statements. */
1502 #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
1503 case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION
1505 /* Block end statements. Errors associated with interchanging these
1506 are detected in gfc_match_end(). */
1508 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1509 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1510 case ST_END_BLOCK: case ST_END_ASSOCIATE
1513 /* Push a new state onto the stack. */
1516 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1518 p
->state
= new_state
;
1519 p
->previous
= gfc_state_stack
;
1521 p
->head
= p
->tail
= NULL
;
1522 p
->do_variable
= NULL
;
1523 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1524 p
->ext
.oacc_declare_clauses
= NULL
;
1526 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1527 construct statement was accepted right before pushing the state. Thus,
1528 the construct's gfc_code is available as tail of the parent state. */
1529 gcc_assert (gfc_state_stack
);
1530 p
->construct
= gfc_state_stack
->tail
;
1532 gfc_state_stack
= p
;
1536 /* Pop the current state. */
1540 gfc_state_stack
= gfc_state_stack
->previous
;
1544 /* Try to find the given state in the state stack. */
1547 gfc_find_state (gfc_compile_state state
)
1551 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1552 if (p
->state
== state
)
1555 return (p
== NULL
) ? false : true;
1559 /* Starts a new level in the statement list. */
1562 new_level (gfc_code
*q
)
1566 p
= q
->block
= gfc_get_code (EXEC_NOP
);
1568 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1574 /* Add the current new_st code structure and adds it to the current
1575 program unit. As a side-effect, it zeroes the new_st. */
1578 add_statement (void)
1582 p
= XCNEW (gfc_code
);
1585 p
->loc
= gfc_current_locus
;
1587 if (gfc_state_stack
->head
== NULL
)
1588 gfc_state_stack
->head
= p
;
1590 gfc_state_stack
->tail
->next
= p
;
1592 while (p
->next
!= NULL
)
1595 gfc_state_stack
->tail
= p
;
1597 gfc_clear_new_st ();
1603 /* Frees everything associated with the current statement. */
1606 undo_new_statement (void)
1608 gfc_free_statements (new_st
.block
);
1609 gfc_free_statements (new_st
.next
);
1610 gfc_free_statement (&new_st
);
1611 gfc_clear_new_st ();
1615 /* If the current statement has a statement label, make sure that it
1616 is allowed to, or should have one. */
1619 check_statement_label (gfc_statement st
)
1623 if (gfc_statement_label
== NULL
)
1625 if (st
== ST_FORMAT
)
1626 gfc_error ("FORMAT statement at %L does not have a statement label",
1633 case ST_END_PROGRAM
:
1634 case ST_END_FUNCTION
:
1635 case ST_END_SUBROUTINE
:
1639 case ST_END_CRITICAL
:
1641 case ST_END_ASSOCIATE
:
1644 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
1645 type
= ST_LABEL_DO_TARGET
;
1647 type
= ST_LABEL_TARGET
;
1651 type
= ST_LABEL_FORMAT
;
1654 /* Statement labels are not restricted from appearing on a
1655 particular line. However, there are plenty of situations
1656 where the resulting label can't be referenced. */
1659 type
= ST_LABEL_BAD_TARGET
;
1663 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1665 new_st
.here
= gfc_statement_label
;
1669 /* Figures out what the enclosing program unit is. This will be a
1670 function, subroutine, program, block data or module. */
1673 gfc_enclosing_unit (gfc_compile_state
* result
)
1677 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1678 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1679 || p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
1680 || p
->state
== COMP_BLOCK_DATA
|| p
->state
== COMP_PROGRAM
)
1689 *result
= COMP_PROGRAM
;
1694 /* Translate a statement enum to a string. */
1697 gfc_ascii_statement (gfc_statement st
)
1703 case ST_ARITHMETIC_IF
:
1704 p
= _("arithmetic IF");
1713 p
= _("attribute declaration");
1749 p
= _("data declaration");
1763 case ST_STRUCTURE_DECL
:
1766 case ST_DERIVED_DECL
:
1767 p
= _("derived type declaration");
1787 case ST_END_ASSOCIATE
:
1788 p
= "END ASSOCIATE";
1793 case ST_END_BLOCK_DATA
:
1794 p
= "END BLOCK DATA";
1796 case ST_END_CRITICAL
:
1808 case ST_END_FUNCTION
:
1814 case ST_END_INTERFACE
:
1815 p
= "END INTERFACE";
1820 case ST_END_SUBMODULE
:
1821 p
= "END SUBMODULE";
1823 case ST_END_PROGRAM
:
1829 case ST_END_SUBROUTINE
:
1830 p
= "END SUBROUTINE";
1835 case ST_END_STRUCTURE
:
1836 p
= "END STRUCTURE";
1850 case ST_EQUIVALENCE
:
1862 case ST_FORALL_BLOCK
: /* Fall through */
1884 case ST_IMPLICIT_NONE
:
1885 p
= "IMPLICIT NONE";
1887 case ST_IMPLIED_ENDDO
:
1888 p
= _("implied END DO");
1920 case ST_MODULE_PROC
:
1921 p
= "MODULE PROCEDURE";
1953 case ST_SYNC_IMAGES
:
1956 case ST_SYNC_MEMORY
:
1971 case ST_WHERE_BLOCK
: /* Fall through */
1982 p
= _("assignment");
1984 case ST_POINTER_ASSIGNMENT
:
1985 p
= _("pointer assignment");
1987 case ST_SELECT_CASE
:
1990 case ST_SELECT_TYPE
:
2005 case ST_STATEMENT_FUNCTION
:
2006 p
= "STATEMENT FUNCTION";
2008 case ST_LABEL_ASSIGNMENT
:
2009 p
= "LABEL ASSIGNMENT";
2012 p
= "ENUM DEFINITION";
2015 p
= "ENUMERATOR DEFINITION";
2020 case ST_OACC_PARALLEL_LOOP
:
2021 p
= "!$ACC PARALLEL LOOP";
2023 case ST_OACC_END_PARALLEL_LOOP
:
2024 p
= "!$ACC END PARALLEL LOOP";
2026 case ST_OACC_PARALLEL
:
2027 p
= "!$ACC PARALLEL";
2029 case ST_OACC_END_PARALLEL
:
2030 p
= "!$ACC END PARALLEL";
2032 case ST_OACC_KERNELS
:
2033 p
= "!$ACC KERNELS";
2035 case ST_OACC_END_KERNELS
:
2036 p
= "!$ACC END KERNELS";
2038 case ST_OACC_KERNELS_LOOP
:
2039 p
= "!$ACC KERNELS LOOP";
2041 case ST_OACC_END_KERNELS_LOOP
:
2042 p
= "!$ACC END KERNELS LOOP";
2047 case ST_OACC_END_DATA
:
2048 p
= "!$ACC END DATA";
2050 case ST_OACC_HOST_DATA
:
2051 p
= "!$ACC HOST_DATA";
2053 case ST_OACC_END_HOST_DATA
:
2054 p
= "!$ACC END HOST_DATA";
2059 case ST_OACC_END_LOOP
:
2060 p
= "!$ACC END LOOP";
2062 case ST_OACC_DECLARE
:
2063 p
= "!$ACC DECLARE";
2065 case ST_OACC_UPDATE
:
2074 case ST_OACC_ENTER_DATA
:
2075 p
= "!$ACC ENTER DATA";
2077 case ST_OACC_EXIT_DATA
:
2078 p
= "!$ACC EXIT DATA";
2080 case ST_OACC_ROUTINE
:
2081 p
= "!$ACC ROUTINE";
2083 case ST_OACC_ATOMIC
:
2086 case ST_OACC_END_ATOMIC
:
2087 p
= "!ACC END ATOMIC";
2092 case ST_OMP_BARRIER
:
2093 p
= "!$OMP BARRIER";
2098 case ST_OMP_CANCELLATION_POINT
:
2099 p
= "!$OMP CANCELLATION POINT";
2101 case ST_OMP_CRITICAL
:
2102 p
= "!$OMP CRITICAL";
2104 case ST_OMP_DECLARE_REDUCTION
:
2105 p
= "!$OMP DECLARE REDUCTION";
2107 case ST_OMP_DECLARE_SIMD
:
2108 p
= "!$OMP DECLARE SIMD";
2110 case ST_OMP_DECLARE_TARGET
:
2111 p
= "!$OMP DECLARE TARGET";
2113 case ST_OMP_DISTRIBUTE
:
2114 p
= "!$OMP DISTRIBUTE";
2116 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
2117 p
= "!$OMP DISTRIBUTE PARALLEL DO";
2119 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2120 p
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
2122 case ST_OMP_DISTRIBUTE_SIMD
:
2123 p
= "!$OMP DISTRIBUTE SIMD";
2128 case ST_OMP_DO_SIMD
:
2129 p
= "!$OMP DO SIMD";
2131 case ST_OMP_END_ATOMIC
:
2132 p
= "!$OMP END ATOMIC";
2134 case ST_OMP_END_CRITICAL
:
2135 p
= "!$OMP END CRITICAL";
2137 case ST_OMP_END_DISTRIBUTE
:
2138 p
= "!$OMP END DISTRIBUTE";
2140 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO
:
2141 p
= "!$OMP END DISTRIBUTE PARALLEL DO";
2143 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
:
2144 p
= "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
2146 case ST_OMP_END_DISTRIBUTE_SIMD
:
2147 p
= "!$OMP END DISTRIBUTE SIMD";
2152 case ST_OMP_END_DO_SIMD
:
2153 p
= "!$OMP END DO SIMD";
2155 case ST_OMP_END_SIMD
:
2156 p
= "!$OMP END SIMD";
2158 case ST_OMP_END_MASTER
:
2159 p
= "!$OMP END MASTER";
2161 case ST_OMP_END_ORDERED
:
2162 p
= "!$OMP END ORDERED";
2164 case ST_OMP_END_PARALLEL
:
2165 p
= "!$OMP END PARALLEL";
2167 case ST_OMP_END_PARALLEL_DO
:
2168 p
= "!$OMP END PARALLEL DO";
2170 case ST_OMP_END_PARALLEL_DO_SIMD
:
2171 p
= "!$OMP END PARALLEL DO SIMD";
2173 case ST_OMP_END_PARALLEL_SECTIONS
:
2174 p
= "!$OMP END PARALLEL SECTIONS";
2176 case ST_OMP_END_PARALLEL_WORKSHARE
:
2177 p
= "!$OMP END PARALLEL WORKSHARE";
2179 case ST_OMP_END_SECTIONS
:
2180 p
= "!$OMP END SECTIONS";
2182 case ST_OMP_END_SINGLE
:
2183 p
= "!$OMP END SINGLE";
2185 case ST_OMP_END_TASK
:
2186 p
= "!$OMP END TASK";
2188 case ST_OMP_END_TARGET
:
2189 p
= "!$OMP END TARGET";
2191 case ST_OMP_END_TARGET_DATA
:
2192 p
= "!$OMP END TARGET DATA";
2194 case ST_OMP_END_TARGET_PARALLEL
:
2195 p
= "!$OMP END TARGET PARALLEL";
2197 case ST_OMP_END_TARGET_PARALLEL_DO
:
2198 p
= "!$OMP END TARGET PARALLEL DO";
2200 case ST_OMP_END_TARGET_PARALLEL_DO_SIMD
:
2201 p
= "!$OMP END TARGET PARALLEL DO SIMD";
2203 case ST_OMP_END_TARGET_SIMD
:
2204 p
= "!$OMP END TARGET SIMD";
2206 case ST_OMP_END_TARGET_TEAMS
:
2207 p
= "!$OMP END TARGET TEAMS";
2209 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
:
2210 p
= "!$OMP END TARGET TEAMS DISTRIBUTE";
2212 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2213 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2215 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2216 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2218 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2219 p
= "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2221 case ST_OMP_END_TASKGROUP
:
2222 p
= "!$OMP END TASKGROUP";
2224 case ST_OMP_END_TASKLOOP
:
2225 p
= "!$OMP END TASKLOOP";
2227 case ST_OMP_END_TASKLOOP_SIMD
:
2228 p
= "!$OMP END TASKLOOP SIMD";
2230 case ST_OMP_END_TEAMS
:
2231 p
= "!$OMP END TEAMS";
2233 case ST_OMP_END_TEAMS_DISTRIBUTE
:
2234 p
= "!$OMP END TEAMS DISTRIBUTE";
2236 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2237 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2239 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2240 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2242 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
:
2243 p
= "!$OMP END TEAMS DISTRIBUTE SIMD";
2245 case ST_OMP_END_WORKSHARE
:
2246 p
= "!$OMP END WORKSHARE";
2254 case ST_OMP_ORDERED
:
2255 case ST_OMP_ORDERED_DEPEND
:
2256 p
= "!$OMP ORDERED";
2258 case ST_OMP_PARALLEL
:
2259 p
= "!$OMP PARALLEL";
2261 case ST_OMP_PARALLEL_DO
:
2262 p
= "!$OMP PARALLEL DO";
2264 case ST_OMP_PARALLEL_DO_SIMD
:
2265 p
= "!$OMP PARALLEL DO SIMD";
2267 case ST_OMP_PARALLEL_SECTIONS
:
2268 p
= "!$OMP PARALLEL SECTIONS";
2270 case ST_OMP_PARALLEL_WORKSHARE
:
2271 p
= "!$OMP PARALLEL WORKSHARE";
2273 case ST_OMP_SECTIONS
:
2274 p
= "!$OMP SECTIONS";
2276 case ST_OMP_SECTION
:
2277 p
= "!$OMP SECTION";
2288 case ST_OMP_TARGET_DATA
:
2289 p
= "!$OMP TARGET DATA";
2291 case ST_OMP_TARGET_ENTER_DATA
:
2292 p
= "!$OMP TARGET ENTER DATA";
2294 case ST_OMP_TARGET_EXIT_DATA
:
2295 p
= "!$OMP TARGET EXIT DATA";
2297 case ST_OMP_TARGET_PARALLEL
:
2298 p
= "!$OMP TARGET PARALLEL";
2300 case ST_OMP_TARGET_PARALLEL_DO
:
2301 p
= "!$OMP TARGET PARALLEL DO";
2303 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
2304 p
= "!$OMP TARGET PARALLEL DO SIMD";
2306 case ST_OMP_TARGET_SIMD
:
2307 p
= "!$OMP TARGET SIMD";
2309 case ST_OMP_TARGET_TEAMS
:
2310 p
= "!$OMP TARGET TEAMS";
2312 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
2313 p
= "!$OMP TARGET TEAMS DISTRIBUTE";
2315 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2316 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2318 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2319 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2321 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2322 p
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2324 case ST_OMP_TARGET_UPDATE
:
2325 p
= "!$OMP TARGET UPDATE";
2330 case ST_OMP_TASKGROUP
:
2331 p
= "!$OMP TASKGROUP";
2333 case ST_OMP_TASKLOOP
:
2334 p
= "!$OMP TASKLOOP";
2336 case ST_OMP_TASKLOOP_SIMD
:
2337 p
= "!$OMP TASKLOOP SIMD";
2339 case ST_OMP_TASKWAIT
:
2340 p
= "!$OMP TASKWAIT";
2342 case ST_OMP_TASKYIELD
:
2343 p
= "!$OMP TASKYIELD";
2348 case ST_OMP_TEAMS_DISTRIBUTE
:
2349 p
= "!$OMP TEAMS DISTRIBUTE";
2351 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2352 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2354 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2355 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2357 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
2358 p
= "!$OMP TEAMS DISTRIBUTE SIMD";
2360 case ST_OMP_THREADPRIVATE
:
2361 p
= "!$OMP THREADPRIVATE";
2363 case ST_OMP_WORKSHARE
:
2364 p
= "!$OMP WORKSHARE";
2367 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2374 /* Create a symbol for the main program and assign it to ns->proc_name. */
2377 main_program_symbol (gfc_namespace
*ns
, const char *name
)
2379 gfc_symbol
*main_program
;
2380 symbol_attribute attr
;
2382 gfc_get_symbol (name
, ns
, &main_program
);
2383 gfc_clear_attr (&attr
);
2384 attr
.flavor
= FL_PROGRAM
;
2385 attr
.proc
= PROC_UNKNOWN
;
2386 attr
.subroutine
= 1;
2387 attr
.access
= ACCESS_PUBLIC
;
2388 attr
.is_main_program
= 1;
2389 main_program
->attr
= attr
;
2390 main_program
->declared_at
= gfc_current_locus
;
2391 ns
->proc_name
= main_program
;
2392 gfc_commit_symbols ();
2396 /* Do whatever is necessary to accept the last statement. */
2399 accept_statement (gfc_statement st
)
2403 case ST_IMPLICIT_NONE
:
2411 gfc_current_ns
->proc_name
= gfc_new_block
;
2414 /* If the statement is the end of a block, lay down a special code
2415 that allows a branch to the end of the block from within the
2416 construct. IF and SELECT are treated differently from DO
2417 (where EXEC_NOP is added inside the loop) for two
2419 1. END DO has a meaning in the sense that after a GOTO to
2420 it, the loop counter must be increased.
2421 2. IF blocks and SELECT blocks can consist of multiple
2422 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
2423 Putting the label before the END IF would make the jump
2424 from, say, the ELSE IF block to the END IF illegal. */
2428 case ST_END_CRITICAL
:
2429 if (gfc_statement_label
!= NULL
)
2431 new_st
.op
= EXEC_END_NESTED_BLOCK
;
2436 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
2437 one parallel block. Thus, we add the special code to the nested block
2438 itself, instead of the parent one. */
2440 case ST_END_ASSOCIATE
:
2441 if (gfc_statement_label
!= NULL
)
2443 new_st
.op
= EXEC_END_BLOCK
;
2448 /* The end-of-program unit statements do not get the special
2449 marker and require a statement of some sort if they are a
2452 case ST_END_PROGRAM
:
2453 case ST_END_FUNCTION
:
2454 case ST_END_SUBROUTINE
:
2455 if (gfc_statement_label
!= NULL
)
2457 new_st
.op
= EXEC_RETURN
;
2462 new_st
.op
= EXEC_END_PROCEDURE
;
2478 gfc_commit_symbols ();
2479 gfc_warning_check ();
2480 gfc_clear_new_st ();
2484 /* Undo anything tentative that has been built for the current statement,
2485 except if a gfc_charlen structure has been added to current namespace's
2486 list of gfc_charlen structure. */
2489 reject_statement (void)
2491 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
2492 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
2494 gfc_reject_data (gfc_current_ns
);
2496 gfc_new_block
= NULL
;
2497 gfc_undo_symbols ();
2498 gfc_clear_warning ();
2499 undo_new_statement ();
2503 /* Generic complaint about an out of order statement. We also do
2504 whatever is necessary to clean up. */
2507 unexpected_statement (gfc_statement st
)
2509 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
2511 reject_statement ();
2515 /* Given the next statement seen by the matcher, make sure that it is
2516 in proper order with the last. This subroutine is initialized by
2517 calling it with an argument of ST_NONE. If there is a problem, we
2518 issue an error and return false. Otherwise we return true.
2520 Individual parsers need to verify that the statements seen are
2521 valid before calling here, i.e., ENTRY statements are not allowed in
2522 INTERFACE blocks. The following diagram is taken from the standard:
2524 +---------------------------------------+
2525 | program subroutine function module |
2526 +---------------------------------------+
2528 +---------------------------------------+
2530 +---------------------------------------+
2532 | +-----------+------------------+
2533 | | parameter | implicit |
2534 | +-----------+------------------+
2535 | format | | derived type |
2536 | entry | parameter | interface |
2537 | | data | specification |
2538 | | | statement func |
2539 | +-----------+------------------+
2540 | | data | executable |
2541 +--------+-----------+------------------+
2543 +---------------------------------------+
2544 | internal module/subprogram |
2545 +---------------------------------------+
2547 +---------------------------------------+
2556 ORDER_IMPLICIT_NONE
,
2564 enum state_order state
;
2565 gfc_statement last_statement
;
2571 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
2577 p
->state
= ORDER_START
;
2581 if (p
->state
> ORDER_USE
)
2583 p
->state
= ORDER_USE
;
2587 if (p
->state
> ORDER_IMPORT
)
2589 p
->state
= ORDER_IMPORT
;
2592 case ST_IMPLICIT_NONE
:
2593 if (p
->state
> ORDER_IMPLICIT
)
2596 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2597 statement disqualifies a USE but not an IMPLICIT NONE.
2598 Duplicate IMPLICIT NONEs are caught when the implicit types
2601 p
->state
= ORDER_IMPLICIT_NONE
;
2605 if (p
->state
> ORDER_IMPLICIT
)
2607 p
->state
= ORDER_IMPLICIT
;
2612 if (p
->state
< ORDER_IMPLICIT_NONE
)
2613 p
->state
= ORDER_IMPLICIT_NONE
;
2617 if (p
->state
>= ORDER_EXEC
)
2619 if (p
->state
< ORDER_IMPLICIT
)
2620 p
->state
= ORDER_IMPLICIT
;
2624 if (p
->state
< ORDER_SPEC
)
2625 p
->state
= ORDER_SPEC
;
2630 case ST_STRUCTURE_DECL
:
2631 case ST_DERIVED_DECL
:
2633 if (p
->state
>= ORDER_EXEC
)
2635 if (p
->state
< ORDER_SPEC
)
2636 p
->state
= ORDER_SPEC
;
2640 /* The OpenMP directives have to be somewhere in the specification
2641 part, but there are no further requirements on their ordering.
2642 Thus don't adjust p->state, just ignore them. */
2643 if (p
->state
>= ORDER_EXEC
)
2649 if (p
->state
< ORDER_EXEC
)
2650 p
->state
= ORDER_EXEC
;
2657 /* All is well, record the statement in case we need it next time. */
2658 p
->where
= gfc_current_locus
;
2659 p
->last_statement
= st
;
2664 gfc_error ("%s statement at %C cannot follow %s statement at %L",
2665 gfc_ascii_statement (st
),
2666 gfc_ascii_statement (p
->last_statement
), &p
->where
);
2672 /* Handle an unexpected end of file. This is a show-stopper... */
2674 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
2677 unexpected_eof (void)
2681 gfc_error ("Unexpected end of file in %qs", gfc_source_file
);
2683 /* Memory cleanup. Move to "second to last". */
2684 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
2687 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
2690 longjmp (eof_buf
, 1);
2694 /* Parse the CONTAINS section of a derived type definition. */
2696 gfc_access gfc_typebound_default_access
;
2699 parse_derived_contains (void)
2702 bool seen_private
= false;
2703 bool seen_comps
= false;
2704 bool error_flag
= false;
2707 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2708 gcc_assert (gfc_current_block ());
2710 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
2712 if (gfc_current_block ()->attr
.sequence
)
2713 gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
2714 " section at %C", gfc_current_block ()->name
);
2715 if (gfc_current_block ()->attr
.is_bind_c
)
2716 gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
2717 " section at %C", gfc_current_block ()->name
);
2719 accept_statement (ST_CONTAINS
);
2720 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
2722 gfc_typebound_default_access
= ACCESS_PUBLIC
;
2728 st
= next_statement ();
2736 gfc_error ("Components in TYPE at %C must precede CONTAINS");
2740 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
2743 accept_statement (ST_PROCEDURE
);
2748 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
2751 accept_statement (ST_GENERIC
);
2756 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
2760 accept_statement (ST_FINAL
);
2768 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
2769 "at %C with empty CONTAINS section")))
2772 /* ST_END_TYPE is accepted by parse_derived after return. */
2776 if (!gfc_find_state (COMP_MODULE
))
2778 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2785 gfc_error ("PRIVATE statement at %C must precede procedure"
2792 gfc_error ("Duplicate PRIVATE statement at %C");
2796 accept_statement (ST_PRIVATE
);
2797 gfc_typebound_default_access
= ACCESS_PRIVATE
;
2798 seen_private
= true;
2802 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2806 gfc_error ("Already inside a CONTAINS block at %C");
2810 unexpected_statement (st
);
2818 reject_statement ();
2822 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2828 /* Set attributes for the parent symbol based on the attributes of a component
2829 and raise errors if conflicting attributes are found for the component. */
2832 check_component (gfc_symbol
*sym
, gfc_component
*c
, gfc_component
**lockp
,
2833 gfc_component
**eventp
)
2835 bool coarray
, lock_type
, event_type
, allocatable
, pointer
;
2836 coarray
= lock_type
= event_type
= allocatable
= pointer
= false;
2837 gfc_component
*lock_comp
= NULL
, *event_comp
= NULL
;
2839 if (lockp
) lock_comp
= *lockp
;
2840 if (eventp
) event_comp
= *eventp
;
2842 /* Look for allocatable components. */
2843 if (c
->attr
.allocatable
2844 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2845 && CLASS_DATA (c
)->attr
.allocatable
)
2846 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
2847 && c
->ts
.u
.derived
->attr
.alloc_comp
))
2850 sym
->attr
.alloc_comp
= 1;
2853 /* Look for pointer components. */
2855 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2856 && CLASS_DATA (c
)->attr
.class_pointer
)
2857 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
2860 sym
->attr
.pointer_comp
= 1;
2863 /* Look for procedure pointer components. */
2864 if (c
->attr
.proc_pointer
2865 || (c
->ts
.type
== BT_DERIVED
2866 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
2867 sym
->attr
.proc_pointer_comp
= 1;
2869 /* Looking for coarray components. */
2870 if (c
->attr
.codimension
2871 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2872 && CLASS_DATA (c
)->attr
.codimension
))
2875 sym
->attr
.coarray_comp
= 1;
2878 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
2879 && !c
->attr
.pointer
)
2882 sym
->attr
.coarray_comp
= 1;
2885 /* Looking for lock_type components. */
2886 if ((c
->ts
.type
== BT_DERIVED
2887 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2888 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
2889 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2890 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2891 == INTMOD_ISO_FORTRAN_ENV
2892 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2893 == ISOFORTRAN_LOCK_TYPE
)
2894 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
2895 && !allocatable
&& !pointer
))
2899 sym
->attr
.lock_comp
= 1;
2902 /* Looking for event_type components. */
2903 if ((c
->ts
.type
== BT_DERIVED
2904 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
2905 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
2906 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2907 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
2908 == INTMOD_ISO_FORTRAN_ENV
2909 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
2910 == ISOFORTRAN_EVENT_TYPE
)
2911 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.event_comp
2912 && !allocatable
&& !pointer
))
2916 sym
->attr
.event_comp
= 1;
2919 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
2920 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
2921 unless there are nondirect [allocatable or pointer] components
2922 involved (cf. 1.3.33.1 and 1.3.33.3). */
2924 if (pointer
&& !coarray
&& lock_type
)
2925 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
2926 "codimension or be a subcomponent of a coarray, "
2927 "which is not possible as the component has the "
2928 "pointer attribute", c
->name
, &c
->loc
);
2929 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
2930 && c
->ts
.u
.derived
->attr
.lock_comp
)
2931 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2932 "of type LOCK_TYPE, which must have a codimension or be a "
2933 "subcomponent of a coarray", c
->name
, &c
->loc
);
2935 if (lock_type
&& allocatable
&& !coarray
)
2936 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
2937 "a codimension", c
->name
, &c
->loc
);
2938 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
2939 && c
->ts
.u
.derived
->attr
.lock_comp
)
2940 gfc_error ("Allocatable component %s at %L must have a codimension as "
2941 "it has a noncoarray subcomponent of type LOCK_TYPE",
2944 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
2945 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2946 "subcomponent of type LOCK_TYPE must have a codimension or "
2947 "be a subcomponent of a coarray. (Variables of type %s may "
2948 "not have a codimension as already a coarray "
2949 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
2951 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
2952 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
2953 "subcomponent of type LOCK_TYPE must have a codimension or "
2954 "be a subcomponent of a coarray. (Variables of type %s may "
2955 "not have a codimension as %s at %L has a codimension or a "
2956 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
2957 sym
->name
, c
->name
, &c
->loc
);
2959 /* Similarly for EVENT TYPE. */
2961 if (pointer
&& !coarray
&& event_type
)
2962 gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
2963 "codimension or be a subcomponent of a coarray, "
2964 "which is not possible as the component has the "
2965 "pointer attribute", c
->name
, &c
->loc
);
2966 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
2967 && c
->ts
.u
.derived
->attr
.event_comp
)
2968 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
2969 "of type EVENT_TYPE, which must have a codimension or be a "
2970 "subcomponent of a coarray", c
->name
, &c
->loc
);
2972 if (event_type
&& allocatable
&& !coarray
)
2973 gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
2974 "a codimension", c
->name
, &c
->loc
);
2975 else if (event_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
2976 && c
->ts
.u
.derived
->attr
.event_comp
)
2977 gfc_error ("Allocatable component %s at %L must have a codimension as "
2978 "it has a noncoarray subcomponent of type EVENT_TYPE",
2981 if (sym
->attr
.coarray_comp
&& !coarray
&& event_type
)
2982 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
2983 "subcomponent of type EVENT_TYPE must have a codimension or "
2984 "be a subcomponent of a coarray. (Variables of type %s may "
2985 "not have a codimension as already a coarray "
2986 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
2988 if (sym
->attr
.event_comp
&& coarray
&& !event_type
)
2989 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
2990 "subcomponent of type EVENT_TYPE must have a codimension or "
2991 "be a subcomponent of a coarray. (Variables of type %s may "
2992 "not have a codimension as %s at %L has a codimension or a "
2993 "coarray subcomponent)", event_comp
->name
, &event_comp
->loc
,
2994 sym
->name
, c
->name
, &c
->loc
);
2996 /* Look for private components. */
2997 if (sym
->component_access
== ACCESS_PRIVATE
2998 || c
->attr
.access
== ACCESS_PRIVATE
2999 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
3000 sym
->attr
.private_comp
= 1;
3002 if (lockp
) *lockp
= lock_comp
;
3003 if (eventp
) *eventp
= event_comp
;
3007 static void parse_struct_map (gfc_statement
);
3009 /* Parse a union component definition within a structure definition. */
3017 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3020 accept_statement(ST_UNION
);
3021 push_state (&s
, COMP_UNION
, gfc_new_block
);
3028 st
= next_statement ();
3029 /* Only MAP declarations valid within a union. */
3036 accept_statement (ST_MAP
);
3037 parse_struct_map (ST_MAP
);
3038 /* Add a component to the union for each map. */
3039 if (!gfc_add_component (un
, gfc_new_block
->name
, &c
))
3041 gfc_internal_error ("failed to create map component '%s'",
3042 gfc_new_block
->name
);
3043 reject_statement ();
3046 c
->ts
.type
= BT_DERIVED
;
3047 c
->ts
.u
.derived
= gfc_new_block
;
3048 /* Normally components get their initialization expressions when they
3049 are created in decl.c (build_struct) so we can look through the
3050 flat component list for initializers during resolution. Unions and
3051 maps create components along with their type definitions so we
3052 have to generate initializers here. */
3053 c
->initializer
= gfc_default_initializer (&c
->ts
);
3058 accept_statement (ST_END_UNION
);
3062 unexpected_statement (st
);
3067 for (c
= un
->components
; c
; c
= c
->next
)
3068 check_component (un
, c
, &lock_comp
, &event_comp
);
3070 /* Add the union as a component in its parent structure. */
3072 if (!gfc_add_component (gfc_current_block (), un
->name
, &c
))
3074 gfc_internal_error ("failed to create union component '%s'", un
->name
);
3075 reject_statement ();
3078 c
->ts
.type
= BT_UNION
;
3079 c
->ts
.u
.derived
= un
;
3080 c
->initializer
= gfc_default_initializer (&c
->ts
);
3082 un
->attr
.zero_comp
= un
->components
== NULL
;
3086 /* Parse a STRUCTURE or MAP. */
3089 parse_struct_map (gfc_statement block
)
3095 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3096 gfc_compile_state comp
;
3099 if (block
== ST_STRUCTURE_DECL
)
3101 comp
= COMP_STRUCTURE
;
3102 ends
= ST_END_STRUCTURE
;
3106 gcc_assert (block
== ST_MAP
);
3111 accept_statement(block
);
3112 push_state (&s
, comp
, gfc_new_block
);
3114 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3117 while (compiling_type
)
3119 st
= next_statement ();
3125 /* Nested structure declarations will be captured as ST_DATA_DECL. */
3126 case ST_STRUCTURE_DECL
:
3127 /* Let a more specific error make it to decode_statement(). */
3128 if (gfc_error_check () == 0)
3129 gfc_error ("Syntax error in nested structure declaration at %C");
3130 reject_statement ();
3131 /* Skip the rest of this statement. */
3132 gfc_error_recovery ();
3136 accept_statement (ST_UNION
);
3141 /* The data declaration was a nested/ad-hoc STRUCTURE field. */
3142 accept_statement (ST_DATA_DECL
);
3143 if (gfc_new_block
&& gfc_new_block
!= gfc_current_block ()
3144 && gfc_new_block
->attr
.flavor
== FL_STRUCT
)
3145 parse_struct_map (ST_STRUCTURE_DECL
);
3148 case ST_END_STRUCTURE
:
3152 accept_statement (st
);
3156 unexpected_statement (st
);
3160 unexpected_statement (st
);
3165 /* Validate each component. */
3166 sym
= gfc_current_block ();
3167 for (c
= sym
->components
; c
; c
= c
->next
)
3168 check_component (sym
, c
, &lock_comp
, &event_comp
);
3170 sym
->attr
.zero_comp
= (sym
->components
== NULL
);
3172 /* Allow parse_union to find this structure to add to its list of maps. */
3173 if (block
== ST_MAP
)
3174 gfc_new_block
= gfc_current_block ();
3180 /* Parse a derived type. */
3183 parse_derived (void)
3185 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
3189 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3191 accept_statement (ST_DERIVED_DECL
);
3192 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
3194 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3201 while (compiling_type
)
3203 st
= next_statement ();
3211 accept_statement (st
);
3216 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
3223 if (!seen_component
)
3224 gfc_notify_std (GFC_STD_F2003
, "Derived type "
3225 "definition at %C without components");
3227 accept_statement (ST_END_TYPE
);
3231 if (!gfc_find_state (COMP_MODULE
))
3233 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3240 gfc_error ("PRIVATE statement at %C must precede "
3241 "structure components");
3246 gfc_error ("Duplicate PRIVATE statement at %C");
3248 s
.sym
->component_access
= ACCESS_PRIVATE
;
3250 accept_statement (ST_PRIVATE
);
3257 gfc_error ("SEQUENCE statement at %C must precede "
3258 "structure components");
3262 if (gfc_current_block ()->attr
.sequence
)
3263 gfc_warning (0, "SEQUENCE attribute at %C already specified in "
3268 gfc_error ("Duplicate SEQUENCE statement at %C");
3272 gfc_add_sequence (&gfc_current_block ()->attr
,
3273 gfc_current_block ()->name
, NULL
);
3277 gfc_notify_std (GFC_STD_F2003
,
3278 "CONTAINS block in derived type"
3279 " definition at %C");
3281 accept_statement (ST_CONTAINS
);
3282 parse_derived_contains ();
3286 unexpected_statement (st
);
3291 /* need to verify that all fields of the derived type are
3292 * interoperable with C if the type is declared to be bind(c)
3294 sym
= gfc_current_block ();
3295 for (c
= sym
->components
; c
; c
= c
->next
)
3296 check_component (sym
, c
, &lock_comp
, &event_comp
);
3298 if (!seen_component
)
3299 sym
->attr
.zero_comp
= 1;
3305 /* Parse an ENUM. */
3313 int seen_enumerator
= 0;
3315 push_state (&s
, COMP_ENUM
, gfc_new_block
);
3319 while (compiling_enum
)
3321 st
= next_statement ();
3329 seen_enumerator
= 1;
3330 accept_statement (st
);
3335 if (!seen_enumerator
)
3336 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
3337 accept_statement (st
);
3341 gfc_free_enum_history ();
3342 unexpected_statement (st
);
3350 /* Parse an interface. We must be able to deal with the possibility
3351 of recursive interfaces. The parse_spec() subroutine is mutually
3352 recursive with parse_interface(). */
3354 static gfc_statement
parse_spec (gfc_statement
);
3357 parse_interface (void)
3359 gfc_compile_state new_state
= COMP_NONE
, current_state
;
3360 gfc_symbol
*prog_unit
, *sym
;
3361 gfc_interface_info save
;
3362 gfc_state_data s1
, s2
;
3365 accept_statement (ST_INTERFACE
);
3367 current_interface
.ns
= gfc_current_ns
;
3368 save
= current_interface
;
3370 sym
= (current_interface
.type
== INTERFACE_GENERIC
3371 || current_interface
.type
== INTERFACE_USER_OP
)
3372 ? gfc_new_block
: NULL
;
3374 push_state (&s1
, COMP_INTERFACE
, sym
);
3375 current_state
= COMP_NONE
;
3378 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
3380 st
= next_statement ();
3388 if (st
== ST_SUBROUTINE
)
3389 new_state
= COMP_SUBROUTINE
;
3390 else if (st
== ST_FUNCTION
)
3391 new_state
= COMP_FUNCTION
;
3392 if (gfc_new_block
->attr
.pointer
)
3394 gfc_new_block
->attr
.pointer
= 0;
3395 gfc_new_block
->attr
.proc_pointer
= 1;
3397 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
3398 gfc_new_block
->formal
, NULL
))
3400 reject_statement ();
3401 gfc_free_namespace (gfc_current_ns
);
3404 /* F2008 C1210 forbids the IMPORT statement in module procedure
3405 interface bodies and the flag is set to import symbols. */
3406 if (gfc_new_block
->attr
.module_procedure
)
3407 gfc_current_ns
->has_import_set
= 1;
3411 case ST_MODULE_PROC
: /* The module procedure matcher makes
3412 sure the context is correct. */
3413 accept_statement (st
);
3414 gfc_free_namespace (gfc_current_ns
);
3417 case ST_END_INTERFACE
:
3418 gfc_free_namespace (gfc_current_ns
);
3419 gfc_current_ns
= current_interface
.ns
;
3423 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
3424 gfc_ascii_statement (st
));
3425 reject_statement ();
3426 gfc_free_namespace (gfc_current_ns
);
3431 /* Make sure that the generic name has the right attribute. */
3432 if (current_interface
.type
== INTERFACE_GENERIC
3433 && current_state
== COMP_NONE
)
3435 if (new_state
== COMP_FUNCTION
&& sym
)
3436 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
3437 else if (new_state
== COMP_SUBROUTINE
&& sym
)
3438 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
3440 current_state
= new_state
;
3443 if (current_interface
.type
== INTERFACE_ABSTRACT
)
3445 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
3446 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
3447 gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
3448 "cannot be the same as an intrinsic type",
3449 gfc_new_block
->name
);
3452 push_state (&s2
, new_state
, gfc_new_block
);
3453 accept_statement (st
);
3454 prog_unit
= gfc_new_block
;
3455 prog_unit
->formal_ns
= gfc_current_ns
;
3456 if (prog_unit
== prog_unit
->formal_ns
->proc_name
3457 && prog_unit
->ns
!= prog_unit
->formal_ns
)
3461 /* Read data declaration statements. */
3462 st
= parse_spec (ST_NONE
);
3463 in_specification_block
= true;
3465 /* Since the interface block does not permit an IMPLICIT statement,
3466 the default type for the function or the result must be taken
3467 from the formal namespace. */
3468 if (new_state
== COMP_FUNCTION
)
3470 if (prog_unit
->result
== prog_unit
3471 && prog_unit
->ts
.type
== BT_UNKNOWN
)
3472 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
3473 else if (prog_unit
->result
!= prog_unit
3474 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
3475 gfc_set_default_type (prog_unit
->result
, 1,
3476 prog_unit
->formal_ns
);
3479 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
3481 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
3482 gfc_ascii_statement (st
));
3483 reject_statement ();
3487 /* Add EXTERNAL attribute to function or subroutine. */
3488 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
3489 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
3491 current_interface
= save
;
3492 gfc_add_interface (prog_unit
);
3495 if (current_interface
.ns
3496 && current_interface
.ns
->proc_name
3497 && strcmp (current_interface
.ns
->proc_name
->name
,
3498 prog_unit
->name
) == 0)
3499 gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
3500 "enclosing procedure", prog_unit
->name
,
3501 ¤t_interface
.ns
->proc_name
->declared_at
);
3510 /* Associate function characteristics by going back to the function
3511 declaration and rematching the prefix. */
3514 match_deferred_characteristics (gfc_typespec
* ts
)
3517 match m
= MATCH_ERROR
;
3518 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3520 loc
= gfc_current_locus
;
3522 gfc_current_locus
= gfc_current_block ()->declared_at
;
3525 gfc_buffer_error (true);
3526 m
= gfc_match_prefix (ts
);
3527 gfc_buffer_error (false);
3529 if (ts
->type
== BT_DERIVED
)
3537 /* Only permit one go at the characteristic association. */
3541 /* Set the function locus correctly. If we have not found the
3542 function name, there is an error. */
3544 && gfc_match ("function% %n", name
) == MATCH_YES
3545 && strcmp (name
, gfc_current_block ()->name
) == 0)
3547 gfc_current_block ()->declared_at
= gfc_current_locus
;
3548 gfc_commit_symbols ();
3553 gfc_undo_symbols ();
3556 gfc_current_locus
=loc
;
3561 /* Check specification-expressions in the function result of the currently
3562 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
3563 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
3564 scope are not yet parsed so this has to be delayed up to parse_spec. */
3567 check_function_result_typed (void)
3571 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
3573 if (!gfc_current_ns
->proc_name
->result
) return;
3575 ts
= gfc_current_ns
->proc_name
->result
->ts
;
3577 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
3578 /* TODO: Extend when KIND type parameters are implemented. */
3579 if (ts
.type
== BT_CHARACTER
&& ts
.u
.cl
&& ts
.u
.cl
->length
)
3580 gfc_expr_check_typed (ts
.u
.cl
->length
, gfc_current_ns
, true);
3584 /* Parse a set of specification statements. Returns the statement
3585 that doesn't fit. */
3587 static gfc_statement
3588 parse_spec (gfc_statement st
)
3591 bool function_result_typed
= false;
3592 bool bad_characteristic
= false;
3595 in_specification_block
= true;
3597 verify_st_order (&ss
, ST_NONE
, false);
3599 st
= next_statement ();
3601 /* If we are not inside a function or don't have a result specified so far,
3602 do nothing special about it. */
3603 if (gfc_current_state () != COMP_FUNCTION
)
3604 function_result_typed
= true;
3607 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
3610 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
3611 function_result_typed
= true;
3616 /* If we're inside a BLOCK construct, some statements are disallowed.
3617 Check this here. Attribute declaration statements like INTENT, OPTIONAL
3618 or VALUE are also disallowed, but they don't have a particular ST_*
3619 key so we have to check for them individually in their matcher routine. */
3620 if (gfc_current_state () == COMP_BLOCK
)
3624 case ST_IMPLICIT_NONE
:
3627 case ST_EQUIVALENCE
:
3628 case ST_STATEMENT_FUNCTION
:
3629 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
3630 gfc_ascii_statement (st
));
3631 reject_statement ();
3637 else if (gfc_current_state () == COMP_BLOCK_DATA
)
3638 /* Fortran 2008, C1116. */
3645 case ST_DERIVED_DECL
:
3646 case ST_END_BLOCK_DATA
:
3647 case ST_EQUIVALENCE
:
3649 case ST_IMPLICIT_NONE
:
3651 case ST_STRUCTURE_DECL
:
3660 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
3661 gfc_ascii_statement (st
));
3662 reject_statement ();
3666 /* If we find a statement that can not be followed by an IMPLICIT statement
3667 (and thus we can expect to see none any further), type the function result
3668 if it has not yet been typed. Be careful not to give the END statement
3669 to verify_st_order! */
3670 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
3672 bool verify_now
= false;
3674 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
3679 verify_st_order (&dummyss
, ST_NONE
, false);
3680 verify_st_order (&dummyss
, st
, false);
3682 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
3688 check_function_result_typed ();
3689 function_result_typed
= true;
3698 case ST_IMPLICIT_NONE
:
3700 if (!function_result_typed
)
3702 check_function_result_typed ();
3703 function_result_typed
= true;
3709 case ST_DATA
: /* Not allowed in interfaces */
3710 if (gfc_current_state () == COMP_INTERFACE
)
3720 case ST_STRUCTURE_DECL
:
3721 case ST_DERIVED_DECL
:
3725 if (!verify_st_order (&ss
, st
, false))
3727 reject_statement ();
3728 st
= next_statement ();
3738 case ST_STRUCTURE_DECL
:
3739 parse_struct_map (ST_STRUCTURE_DECL
);
3742 case ST_DERIVED_DECL
:
3748 if (gfc_current_state () != COMP_MODULE
)
3750 gfc_error ("%s statement must appear in a MODULE",
3751 gfc_ascii_statement (st
));
3752 reject_statement ();
3756 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
3758 gfc_error ("%s statement at %C follows another accessibility "
3759 "specification", gfc_ascii_statement (st
));
3760 reject_statement ();
3764 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
3765 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3769 case ST_STATEMENT_FUNCTION
:
3770 if (gfc_current_state () == COMP_MODULE
3771 || gfc_current_state () == COMP_SUBMODULE
)
3773 unexpected_statement (st
);
3781 accept_statement (st
);
3782 st
= next_statement ();
3786 accept_statement (st
);
3788 st
= next_statement ();
3791 case ST_GET_FCN_CHARACTERISTICS
:
3792 /* This statement triggers the association of a function's result
3794 ts
= &gfc_current_block ()->result
->ts
;
3795 if (match_deferred_characteristics (ts
) != MATCH_YES
)
3796 bad_characteristic
= true;
3798 st
= next_statement ();
3805 /* If match_deferred_characteristics failed, then there is an error. */
3806 if (bad_characteristic
)
3808 ts
= &gfc_current_block ()->result
->ts
;
3809 if (ts
->type
!= BT_DERIVED
)
3810 gfc_error ("Bad kind expression for function %qs at %L",
3811 gfc_current_block ()->name
,
3812 &gfc_current_block ()->declared_at
);
3814 gfc_error ("The type for function %qs at %L is not accessible",
3815 gfc_current_block ()->name
,
3816 &gfc_current_block ()->declared_at
);
3818 gfc_current_block ()->ts
.kind
= 0;
3819 /* Keep the derived type; if it's bad, it will be discovered later. */
3820 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
3821 ts
->type
= BT_UNKNOWN
;
3824 in_specification_block
= false;
3830 /* Parse a WHERE block, (not a simple WHERE statement). */
3833 parse_where_block (void)
3835 int seen_empty_else
;
3840 accept_statement (ST_WHERE_BLOCK
);
3841 top
= gfc_state_stack
->tail
;
3843 push_state (&s
, COMP_WHERE
, gfc_new_block
);
3845 d
= add_statement ();
3846 d
->expr1
= top
->expr1
;
3852 seen_empty_else
= 0;
3856 st
= next_statement ();
3862 case ST_WHERE_BLOCK
:
3863 parse_where_block ();
3868 accept_statement (st
);
3872 if (seen_empty_else
)
3874 gfc_error ("ELSEWHERE statement at %C follows previous "
3875 "unmasked ELSEWHERE");
3876 reject_statement ();
3880 if (new_st
.expr1
== NULL
)
3881 seen_empty_else
= 1;
3883 d
= new_level (gfc_state_stack
->head
);
3885 d
->expr1
= new_st
.expr1
;
3887 accept_statement (st
);
3892 accept_statement (st
);
3896 gfc_error ("Unexpected %s statement in WHERE block at %C",
3897 gfc_ascii_statement (st
));
3898 reject_statement ();
3902 while (st
!= ST_END_WHERE
);
3908 /* Parse a FORALL block (not a simple FORALL statement). */
3911 parse_forall_block (void)
3917 accept_statement (ST_FORALL_BLOCK
);
3918 top
= gfc_state_stack
->tail
;
3920 push_state (&s
, COMP_FORALL
, gfc_new_block
);
3922 d
= add_statement ();
3923 d
->op
= EXEC_FORALL
;
3928 st
= next_statement ();
3933 case ST_POINTER_ASSIGNMENT
:
3936 accept_statement (st
);
3939 case ST_WHERE_BLOCK
:
3940 parse_where_block ();
3943 case ST_FORALL_BLOCK
:
3944 parse_forall_block ();
3948 accept_statement (st
);
3955 gfc_error ("Unexpected %s statement in FORALL block at %C",
3956 gfc_ascii_statement (st
));
3958 reject_statement ();
3962 while (st
!= ST_END_FORALL
);
3968 static gfc_statement
parse_executable (gfc_statement
);
3970 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
3973 parse_if_block (void)
3982 accept_statement (ST_IF_BLOCK
);
3984 top
= gfc_state_stack
->tail
;
3985 push_state (&s
, COMP_IF
, gfc_new_block
);
3987 new_st
.op
= EXEC_IF
;
3988 d
= add_statement ();
3990 d
->expr1
= top
->expr1
;
3996 st
= parse_executable (ST_NONE
);
4006 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
4007 "statement at %L", &else_locus
);
4009 reject_statement ();
4013 d
= new_level (gfc_state_stack
->head
);
4015 d
->expr1
= new_st
.expr1
;
4017 accept_statement (st
);
4024 gfc_error ("Duplicate ELSE statements at %L and %C",
4026 reject_statement ();
4031 else_locus
= gfc_current_locus
;
4033 d
= new_level (gfc_state_stack
->head
);
4036 accept_statement (st
);
4044 unexpected_statement (st
);
4048 while (st
!= ST_ENDIF
);
4051 accept_statement (st
);
4055 /* Parse a SELECT block. */
4058 parse_select_block (void)
4064 accept_statement (ST_SELECT_CASE
);
4066 cp
= gfc_state_stack
->tail
;
4067 push_state (&s
, COMP_SELECT
, gfc_new_block
);
4069 /* Make sure that the next statement is a CASE or END SELECT. */
4072 st
= next_statement ();
4075 if (st
== ST_END_SELECT
)
4077 /* Empty SELECT CASE is OK. */
4078 accept_statement (st
);
4085 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
4088 reject_statement ();
4091 /* At this point, we're got a nonempty select block. */
4092 cp
= new_level (cp
);
4095 accept_statement (st
);
4099 st
= parse_executable (ST_NONE
);
4106 cp
= new_level (gfc_state_stack
->head
);
4108 gfc_clear_new_st ();
4110 accept_statement (st
);
4116 /* Can't have an executable statement because of
4117 parse_executable(). */
4119 unexpected_statement (st
);
4123 while (st
!= ST_END_SELECT
);
4126 accept_statement (st
);
4130 /* Pop the current selector from the SELECT TYPE stack. */
4133 select_type_pop (void)
4135 gfc_select_type_stack
*old
= select_type_stack
;
4136 select_type_stack
= old
->prev
;
4141 /* Parse a SELECT TYPE construct (F03:R821). */
4144 parse_select_type_block (void)
4150 gfc_current_ns
= new_st
.ext
.block
.ns
;
4151 accept_statement (ST_SELECT_TYPE
);
4153 cp
= gfc_state_stack
->tail
;
4154 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
4156 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
4160 st
= next_statement ();
4163 if (st
== ST_END_SELECT
)
4164 /* Empty SELECT CASE is OK. */
4166 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
4169 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
4170 "following SELECT TYPE at %C");
4172 reject_statement ();
4175 /* At this point, we're got a nonempty select block. */
4176 cp
= new_level (cp
);
4179 accept_statement (st
);
4183 st
= parse_executable (ST_NONE
);
4191 cp
= new_level (gfc_state_stack
->head
);
4193 gfc_clear_new_st ();
4195 accept_statement (st
);
4201 /* Can't have an executable statement because of
4202 parse_executable(). */
4204 unexpected_statement (st
);
4208 while (st
!= ST_END_SELECT
);
4212 accept_statement (st
);
4213 gfc_current_ns
= gfc_current_ns
->parent
;
4218 /* Given a symbol, make sure it is not an iteration variable for a DO
4219 statement. This subroutine is called when the symbol is seen in a
4220 context that causes it to become redefined. If the symbol is an
4221 iterator, we generate an error message and return nonzero. */
4224 gfc_check_do_variable (gfc_symtree
*st
)
4228 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
4229 if (s
->do_variable
== st
)
4231 gfc_error_now ("Variable %qs at %C cannot be redefined inside "
4232 "loop beginning at %L", st
->name
, &s
->head
->loc
);
4240 /* Checks to see if the current statement label closes an enddo.
4241 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
4242 an error) if it incorrectly closes an ENDDO. */
4245 check_do_closure (void)
4249 if (gfc_statement_label
== NULL
)
4252 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
4253 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4257 return 0; /* No loops to close */
4259 if (p
->ext
.end_do_label
== gfc_statement_label
)
4261 if (p
== gfc_state_stack
)
4264 gfc_error ("End of nonblock DO statement at %C is within another block");
4268 /* At this point, the label doesn't terminate the innermost loop.
4269 Make sure it doesn't terminate another one. */
4270 for (; p
; p
= p
->previous
)
4271 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4272 && p
->ext
.end_do_label
== gfc_statement_label
)
4274 gfc_error ("End of nonblock DO statement at %C is interwoven "
4275 "with another DO loop");
4283 /* Parse a series of contained program units. */
4285 static void parse_progunit (gfc_statement
);
4288 /* Parse a CRITICAL block. */
4291 parse_critical_block (void)
4294 gfc_state_data s
, *sd
;
4297 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4298 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
4299 gfc_error_now (is_oacc (sd
)
4300 ? "CRITICAL block inside of OpenACC region at %C"
4301 : "CRITICAL block inside of OpenMP region at %C");
4303 s
.ext
.end_do_label
= new_st
.label1
;
4305 accept_statement (ST_CRITICAL
);
4306 top
= gfc_state_stack
->tail
;
4308 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
4310 d
= add_statement ();
4311 d
->op
= EXEC_CRITICAL
;
4316 st
= parse_executable (ST_NONE
);
4324 case ST_END_CRITICAL
:
4325 if (s
.ext
.end_do_label
!= NULL
4326 && s
.ext
.end_do_label
!= gfc_statement_label
)
4327 gfc_error_now ("Statement label in END CRITICAL at %C does not "
4328 "match CRITICAL label");
4330 if (gfc_statement_label
!= NULL
)
4332 new_st
.op
= EXEC_NOP
;
4338 unexpected_statement (st
);
4342 while (st
!= ST_END_CRITICAL
);
4345 accept_statement (st
);
4349 /* Set up the local namespace for a BLOCK construct. */
4352 gfc_build_block_ns (gfc_namespace
*parent_ns
)
4354 gfc_namespace
* my_ns
;
4355 static int numblock
= 1;
4357 my_ns
= gfc_get_namespace (parent_ns
, 1);
4358 my_ns
->construct_entities
= 1;
4360 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
4361 code generation (so it must not be NULL).
4362 We set its recursive argument if our container procedure is recursive, so
4363 that local variables are accordingly placed on the stack when it
4364 will be necessary. */
4366 my_ns
->proc_name
= gfc_new_block
;
4370 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
4372 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
4373 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
4374 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
4375 my_ns
->proc_name
->name
, NULL
);
4377 gfc_commit_symbol (my_ns
->proc_name
);
4380 if (parent_ns
->proc_name
)
4381 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
4387 /* Parse a BLOCK construct. */
4390 parse_block_construct (void)
4392 gfc_namespace
* my_ns
;
4393 gfc_namespace
* my_parent
;
4396 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
4398 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4400 new_st
.op
= EXEC_BLOCK
;
4401 new_st
.ext
.block
.ns
= my_ns
;
4402 new_st
.ext
.block
.assoc
= NULL
;
4403 accept_statement (ST_BLOCK
);
4405 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
4406 gfc_current_ns
= my_ns
;
4407 my_parent
= my_ns
->parent
;
4409 parse_progunit (ST_NONE
);
4411 /* Don't depend on the value of gfc_current_ns; it might have been
4412 reset if the block had errors and was cleaned up. */
4413 gfc_current_ns
= my_parent
;
4419 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
4420 behind the scenes with compiler-generated variables. */
4423 parse_associate (void)
4425 gfc_namespace
* my_ns
;
4428 gfc_association_list
* a
;
4430 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
4432 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4434 new_st
.op
= EXEC_BLOCK
;
4435 new_st
.ext
.block
.ns
= my_ns
;
4436 gcc_assert (new_st
.ext
.block
.assoc
);
4438 /* Add all associate-names as BLOCK variables. Creating them is enough
4439 for now, they'll get their values during trans-* phase. */
4440 gfc_current_ns
= my_ns
;
4441 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
4445 gfc_array_ref
*array_ref
;
4447 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
4451 sym
->attr
.flavor
= FL_VARIABLE
;
4453 sym
->declared_at
= a
->where
;
4454 gfc_set_sym_referenced (sym
);
4456 /* Initialize the typespec. It is not available in all cases,
4457 however, as it may only be set on the target during resolution.
4458 Still, sometimes it helps to have it right now -- especially
4459 for parsing component references on the associate-name
4460 in case of association to a derived-type. */
4461 sym
->ts
= a
->target
->ts
;
4463 /* Check if the target expression is array valued. This can not always
4464 be done by looking at target.rank, because that might not have been
4465 set yet. Therefore traverse the chain of refs, looking for the last
4466 array ref and evaluate that. */
4468 for (ref
= a
->target
->ref
; ref
; ref
= ref
->next
)
4469 if (ref
->type
== REF_ARRAY
)
4470 array_ref
= &ref
->u
.ar
;
4471 if (array_ref
|| a
->target
->rank
)
4478 /* Count the dimension, that have a non-scalar extend. */
4479 for (dim
= 0; dim
< array_ref
->dimen
; ++dim
)
4480 if (array_ref
->dimen_type
[dim
] != DIMEN_ELEMENT
4481 && !(array_ref
->dimen_type
[dim
] == DIMEN_UNKNOWN
4482 && array_ref
->end
[dim
] == NULL
4483 && array_ref
->start
[dim
] != NULL
))
4487 rank
= a
->target
->rank
;
4488 /* When the rank is greater than zero then sym will be an array. */
4489 if (sym
->ts
.type
== BT_CLASS
)
4491 if ((!CLASS_DATA (sym
)->as
&& rank
!= 0)
4492 || (CLASS_DATA (sym
)->as
4493 && CLASS_DATA (sym
)->as
->rank
!= rank
))
4495 /* Don't just (re-)set the attr and as in the sym.ts,
4496 because this modifies the target's attr and as. Copy the
4497 data and do a build_class_symbol. */
4498 symbol_attribute attr
= CLASS_DATA (a
->target
)->attr
;
4499 int corank
= gfc_get_corank (a
->target
);
4504 as
= gfc_get_array_spec ();
4505 as
->type
= AS_DEFERRED
;
4507 as
->corank
= corank
;
4508 attr
.dimension
= rank
? 1 : 0;
4509 attr
.codimension
= corank
? 1 : 0;
4514 attr
.dimension
= attr
.codimension
= 0;
4517 type
= CLASS_DATA (sym
)->ts
;
4518 if (!gfc_build_class_symbol (&type
,
4522 sym
->ts
.type
= BT_CLASS
;
4523 sym
->attr
.class_ok
= 1;
4526 sym
->attr
.class_ok
= 1;
4528 else if ((!sym
->as
&& rank
!= 0)
4529 || (sym
->as
&& sym
->as
->rank
!= rank
))
4531 as
= gfc_get_array_spec ();
4532 as
->type
= AS_DEFERRED
;
4534 as
->corank
= gfc_get_corank (a
->target
);
4536 sym
->attr
.dimension
= 1;
4538 sym
->attr
.codimension
= 1;
4543 accept_statement (ST_ASSOCIATE
);
4544 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
4547 st
= parse_executable (ST_NONE
);
4554 accept_statement (st
);
4555 my_ns
->code
= gfc_state_stack
->head
;
4559 unexpected_statement (st
);
4563 gfc_current_ns
= gfc_current_ns
->parent
;
4568 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
4569 handled inside of parse_executable(), because they aren't really
4573 parse_do_block (void)
4582 s
.ext
.end_do_label
= new_st
.label1
;
4584 if (new_st
.ext
.iterator
!= NULL
)
4585 stree
= new_st
.ext
.iterator
->var
->symtree
;
4589 accept_statement (ST_DO
);
4591 top
= gfc_state_stack
->tail
;
4592 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
4595 s
.do_variable
= stree
;
4597 top
->block
= new_level (top
);
4598 top
->block
->op
= EXEC_DO
;
4601 st
= parse_executable (ST_NONE
);
4609 if (s
.ext
.end_do_label
!= NULL
4610 && s
.ext
.end_do_label
!= gfc_statement_label
)
4611 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
4614 if (gfc_statement_label
!= NULL
)
4616 new_st
.op
= EXEC_NOP
;
4621 case ST_IMPLIED_ENDDO
:
4622 /* If the do-stmt of this DO construct has a do-construct-name,
4623 the corresponding end-do must be an end-do-stmt (with a matching
4624 name, but in that case we must have seen ST_ENDDO first).
4625 We only complain about this in pedantic mode. */
4626 if (gfc_current_block () != NULL
)
4627 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
4628 &gfc_current_block()->declared_at
);
4633 unexpected_statement (st
);
4638 accept_statement (st
);
4642 /* Parse the statements of OpenMP do/parallel do. */
4644 static gfc_statement
4645 parse_omp_do (gfc_statement omp_st
)
4651 accept_statement (omp_st
);
4653 cp
= gfc_state_stack
->tail
;
4654 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4655 np
= new_level (cp
);
4661 st
= next_statement ();
4664 else if (st
== ST_DO
)
4667 unexpected_statement (st
);
4671 if (gfc_statement_label
!= NULL
4672 && gfc_state_stack
->previous
!= NULL
4673 && gfc_state_stack
->previous
->state
== COMP_DO
4674 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4682 there should be no !$OMP END DO. */
4684 return ST_IMPLIED_ENDDO
;
4687 check_do_closure ();
4690 st
= next_statement ();
4691 gfc_statement omp_end_st
= ST_OMP_END_DO
;
4694 case ST_OMP_DISTRIBUTE
: omp_end_st
= ST_OMP_END_DISTRIBUTE
; break;
4695 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4696 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4698 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4699 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4701 case ST_OMP_DISTRIBUTE_SIMD
:
4702 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4704 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
4705 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
4706 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
4707 case ST_OMP_PARALLEL_DO_SIMD
:
4708 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
4710 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
4711 case ST_OMP_TARGET_PARALLEL_DO
:
4712 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO
;
4714 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
4715 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO_SIMD
;
4717 case ST_OMP_TARGET_SIMD
: omp_end_st
= ST_OMP_END_TARGET_SIMD
; break;
4718 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4719 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4721 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4722 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4724 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4725 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4727 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4728 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4730 case ST_OMP_TASKLOOP
: omp_end_st
= ST_OMP_END_TASKLOOP
; break;
4731 case ST_OMP_TASKLOOP_SIMD
: omp_end_st
= ST_OMP_END_TASKLOOP_SIMD
; break;
4732 case ST_OMP_TEAMS_DISTRIBUTE
:
4733 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4735 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4736 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4738 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4739 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4741 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4742 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4744 default: gcc_unreachable ();
4746 if (st
== omp_end_st
)
4748 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
4749 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4751 gcc_assert (new_st
.op
== EXEC_NOP
);
4752 gfc_clear_new_st ();
4753 gfc_commit_symbols ();
4754 gfc_warning_check ();
4755 st
= next_statement ();
4761 /* Parse the statements of OpenMP atomic directive. */
4763 static gfc_statement
4764 parse_omp_oacc_atomic (bool omp_p
)
4766 gfc_statement st
, st_atomic
, st_end_atomic
;
4773 st_atomic
= ST_OMP_ATOMIC
;
4774 st_end_atomic
= ST_OMP_END_ATOMIC
;
4778 st_atomic
= ST_OACC_ATOMIC
;
4779 st_end_atomic
= ST_OACC_END_ATOMIC
;
4781 accept_statement (st_atomic
);
4783 cp
= gfc_state_stack
->tail
;
4784 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4785 np
= new_level (cp
);
4788 np
->ext
.omp_atomic
= cp
->ext
.omp_atomic
;
4789 count
= 1 + ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4790 == GFC_OMP_ATOMIC_CAPTURE
);
4794 st
= next_statement ();
4797 else if (st
== ST_ASSIGNMENT
)
4799 accept_statement (st
);
4803 unexpected_statement (st
);
4808 st
= next_statement ();
4809 if (st
== st_end_atomic
)
4811 gfc_clear_new_st ();
4812 gfc_commit_symbols ();
4813 gfc_warning_check ();
4814 st
= next_statement ();
4816 else if ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
4817 == GFC_OMP_ATOMIC_CAPTURE
)
4818 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
4823 /* Parse the statements of an OpenACC structured block. */
4826 parse_oacc_structured_block (gfc_statement acc_st
)
4828 gfc_statement st
, acc_end_st
;
4830 gfc_state_data s
, *sd
;
4832 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4833 if (sd
->state
== COMP_CRITICAL
)
4834 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4836 accept_statement (acc_st
);
4838 cp
= gfc_state_stack
->tail
;
4839 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4840 np
= new_level (cp
);
4845 case ST_OACC_PARALLEL
:
4846 acc_end_st
= ST_OACC_END_PARALLEL
;
4848 case ST_OACC_KERNELS
:
4849 acc_end_st
= ST_OACC_END_KERNELS
;
4852 acc_end_st
= ST_OACC_END_DATA
;
4854 case ST_OACC_HOST_DATA
:
4855 acc_end_st
= ST_OACC_END_HOST_DATA
;
4863 st
= parse_executable (ST_NONE
);
4866 else if (st
!= acc_end_st
)
4868 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
4869 reject_statement ();
4872 while (st
!= acc_end_st
);
4874 gcc_assert (new_st
.op
== EXEC_NOP
);
4876 gfc_clear_new_st ();
4877 gfc_commit_symbols ();
4878 gfc_warning_check ();
4882 /* Parse the statements of OpenACC loop/parallel loop/kernels loop. */
4884 static gfc_statement
4885 parse_oacc_loop (gfc_statement acc_st
)
4889 gfc_state_data s
, *sd
;
4891 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4892 if (sd
->state
== COMP_CRITICAL
)
4893 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
4895 accept_statement (acc_st
);
4897 cp
= gfc_state_stack
->tail
;
4898 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4899 np
= new_level (cp
);
4905 st
= next_statement ();
4908 else if (st
== ST_DO
)
4912 gfc_error ("Expected DO loop at %C");
4913 reject_statement ();
4918 if (gfc_statement_label
!= NULL
4919 && gfc_state_stack
->previous
!= NULL
4920 && gfc_state_stack
->previous
->state
== COMP_DO
4921 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4924 return ST_IMPLIED_ENDDO
;
4927 check_do_closure ();
4930 st
= next_statement ();
4931 if (st
== ST_OACC_END_LOOP
)
4932 gfc_warning (0, "Redundant !$ACC END LOOP at %C");
4933 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
4934 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
4935 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
4937 gcc_assert (new_st
.op
== EXEC_NOP
);
4938 gfc_clear_new_st ();
4939 gfc_commit_symbols ();
4940 gfc_warning_check ();
4941 st
= next_statement ();
4947 /* Parse the statements of an OpenMP structured block. */
4950 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
4952 gfc_statement st
, omp_end_st
;
4956 accept_statement (omp_st
);
4958 cp
= gfc_state_stack
->tail
;
4959 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4960 np
= new_level (cp
);
4966 case ST_OMP_PARALLEL
:
4967 omp_end_st
= ST_OMP_END_PARALLEL
;
4969 case ST_OMP_PARALLEL_SECTIONS
:
4970 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
4972 case ST_OMP_SECTIONS
:
4973 omp_end_st
= ST_OMP_END_SECTIONS
;
4975 case ST_OMP_ORDERED
:
4976 omp_end_st
= ST_OMP_END_ORDERED
;
4978 case ST_OMP_CRITICAL
:
4979 omp_end_st
= ST_OMP_END_CRITICAL
;
4982 omp_end_st
= ST_OMP_END_MASTER
;
4985 omp_end_st
= ST_OMP_END_SINGLE
;
4988 omp_end_st
= ST_OMP_END_TARGET
;
4990 case ST_OMP_TARGET_DATA
:
4991 omp_end_st
= ST_OMP_END_TARGET_DATA
;
4993 case ST_OMP_TARGET_TEAMS
:
4994 omp_end_st
= ST_OMP_END_TARGET_TEAMS
;
4996 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4997 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4999 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5000 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5002 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5003 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5005 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5006 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
5009 omp_end_st
= ST_OMP_END_TASK
;
5011 case ST_OMP_TASKGROUP
:
5012 omp_end_st
= ST_OMP_END_TASKGROUP
;
5015 omp_end_st
= ST_OMP_END_TEAMS
;
5017 case ST_OMP_TEAMS_DISTRIBUTE
:
5018 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
5020 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5021 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5023 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5024 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5026 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5027 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
5029 case ST_OMP_DISTRIBUTE
:
5030 omp_end_st
= ST_OMP_END_DISTRIBUTE
;
5032 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5033 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
5035 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5036 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
5038 case ST_OMP_DISTRIBUTE_SIMD
:
5039 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
5041 case ST_OMP_WORKSHARE
:
5042 omp_end_st
= ST_OMP_END_WORKSHARE
;
5044 case ST_OMP_PARALLEL_WORKSHARE
:
5045 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
5053 if (workshare_stmts_only
)
5055 /* Inside of !$omp workshare, only
5058 where statements and constructs
5059 forall statements and constructs
5063 are allowed. For !$omp critical these
5064 restrictions apply recursively. */
5067 st
= next_statement ();
5078 accept_statement (st
);
5081 case ST_WHERE_BLOCK
:
5082 parse_where_block ();
5085 case ST_FORALL_BLOCK
:
5086 parse_forall_block ();
5089 case ST_OMP_PARALLEL
:
5090 case ST_OMP_PARALLEL_SECTIONS
:
5091 parse_omp_structured_block (st
, false);
5094 case ST_OMP_PARALLEL_WORKSHARE
:
5095 case ST_OMP_CRITICAL
:
5096 parse_omp_structured_block (st
, true);
5099 case ST_OMP_PARALLEL_DO
:
5100 case ST_OMP_PARALLEL_DO_SIMD
:
5101 st
= parse_omp_do (st
);
5105 st
= parse_omp_oacc_atomic (true);
5116 st
= next_statement ();
5120 st
= parse_executable (ST_NONE
);
5123 else if (st
== ST_OMP_SECTION
5124 && (omp_st
== ST_OMP_SECTIONS
5125 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
5127 np
= new_level (np
);
5131 else if (st
!= omp_end_st
)
5132 unexpected_statement (st
);
5134 while (st
!= omp_end_st
);
5138 case EXEC_OMP_END_NOWAIT
:
5139 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
5141 case EXEC_OMP_END_CRITICAL
:
5142 if (((cp
->ext
.omp_clauses
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
5143 || (new_st
.ext
.omp_name
!= NULL
5144 && strcmp (cp
->ext
.omp_clauses
->critical_name
,
5145 new_st
.ext
.omp_name
) != 0))
5146 gfc_error ("Name after !$omp critical and !$omp end critical does "
5148 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
5149 new_st
.ext
.omp_name
= NULL
;
5151 case EXEC_OMP_END_SINGLE
:
5152 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
5153 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
5154 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
5155 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
5163 gfc_clear_new_st ();
5164 gfc_commit_symbols ();
5165 gfc_warning_check ();
5170 /* Accept a series of executable statements. We return the first
5171 statement that doesn't fit to the caller. Any block statements are
5172 passed on to the correct handler, which usually passes the buck
5175 static gfc_statement
5176 parse_executable (gfc_statement st
)
5181 st
= next_statement ();
5185 close_flag
= check_do_closure ();
5190 case ST_END_PROGRAM
:
5193 case ST_END_FUNCTION
:
5198 case ST_END_SUBROUTINE
:
5203 case ST_SELECT_CASE
:
5204 gfc_error ("%s statement at %C cannot terminate a non-block "
5205 "DO loop", gfc_ascii_statement (st
));
5218 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
5219 "first executable statement");
5225 accept_statement (st
);
5226 if (close_flag
== 1)
5227 return ST_IMPLIED_ENDDO
;
5231 parse_block_construct ();
5242 case ST_SELECT_CASE
:
5243 parse_select_block ();
5246 case ST_SELECT_TYPE
:
5247 parse_select_type_block ();
5252 if (check_do_closure () == 1)
5253 return ST_IMPLIED_ENDDO
;
5257 parse_critical_block ();
5260 case ST_WHERE_BLOCK
:
5261 parse_where_block ();
5264 case ST_FORALL_BLOCK
:
5265 parse_forall_block ();
5268 case ST_OACC_PARALLEL_LOOP
:
5269 case ST_OACC_KERNELS_LOOP
:
5271 st
= parse_oacc_loop (st
);
5272 if (st
== ST_IMPLIED_ENDDO
)
5276 case ST_OACC_PARALLEL
:
5277 case ST_OACC_KERNELS
:
5279 case ST_OACC_HOST_DATA
:
5280 parse_oacc_structured_block (st
);
5283 case ST_OMP_PARALLEL
:
5284 case ST_OMP_PARALLEL_SECTIONS
:
5285 case ST_OMP_SECTIONS
:
5286 case ST_OMP_ORDERED
:
5287 case ST_OMP_CRITICAL
:
5291 case ST_OMP_TARGET_DATA
:
5292 case ST_OMP_TARGET_PARALLEL
:
5293 case ST_OMP_TARGET_TEAMS
:
5296 case ST_OMP_TASKGROUP
:
5297 parse_omp_structured_block (st
, false);
5300 case ST_OMP_WORKSHARE
:
5301 case ST_OMP_PARALLEL_WORKSHARE
:
5302 parse_omp_structured_block (st
, true);
5305 case ST_OMP_DISTRIBUTE
:
5306 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5307 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5308 case ST_OMP_DISTRIBUTE_SIMD
:
5310 case ST_OMP_DO_SIMD
:
5311 case ST_OMP_PARALLEL_DO
:
5312 case ST_OMP_PARALLEL_DO_SIMD
:
5314 case ST_OMP_TARGET_PARALLEL_DO
:
5315 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
5316 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5317 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5318 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5319 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5320 case ST_OMP_TASKLOOP
:
5321 case ST_OMP_TASKLOOP_SIMD
:
5322 case ST_OMP_TEAMS_DISTRIBUTE
:
5323 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5324 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5325 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5326 st
= parse_omp_do (st
);
5327 if (st
== ST_IMPLIED_ENDDO
)
5331 case ST_OACC_ATOMIC
:
5332 st
= parse_omp_oacc_atomic (false);
5336 st
= parse_omp_oacc_atomic (true);
5343 st
= next_statement ();
5348 /* Fix the symbols for sibling functions. These are incorrectly added to
5349 the child namespace as the parser didn't know about this procedure. */
5352 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
5356 gfc_symbol
*old_sym
;
5358 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
5360 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
5362 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
5363 goto fixup_contained
;
5365 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
5366 && sym
->attr
.generic
&& sym
->attr
.function
)
5367 ||(sym
->attr
.flavor
== FL_DERIVED
5368 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
5369 goto fixup_contained
;
5371 old_sym
= st
->n
.sym
;
5372 if (old_sym
->ns
== ns
5373 && !old_sym
->attr
.contained
5375 /* By 14.6.1.3, host association should be excluded
5376 for the following. */
5377 && !(old_sym
->attr
.external
5378 || (old_sym
->ts
.type
!= BT_UNKNOWN
5379 && !old_sym
->attr
.implicit_type
)
5380 || old_sym
->attr
.flavor
== FL_PARAMETER
5381 || old_sym
->attr
.use_assoc
5382 || old_sym
->attr
.in_common
5383 || old_sym
->attr
.in_equivalence
5384 || old_sym
->attr
.data
5385 || old_sym
->attr
.dummy
5386 || old_sym
->attr
.result
5387 || old_sym
->attr
.dimension
5388 || old_sym
->attr
.allocatable
5389 || old_sym
->attr
.intrinsic
5390 || old_sym
->attr
.generic
5391 || old_sym
->attr
.flavor
== FL_NAMELIST
5392 || old_sym
->attr
.flavor
== FL_LABEL
5393 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
5395 /* Replace it with the symbol from the parent namespace. */
5399 gfc_release_symbol (old_sym
);
5403 /* Do the same for any contained procedures. */
5404 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
5409 parse_contained (int module
)
5411 gfc_namespace
*ns
, *parent_ns
, *tmp
;
5412 gfc_state_data s1
, s2
;
5417 int contains_statements
= 0;
5420 push_state (&s1
, COMP_CONTAINS
, NULL
);
5421 parent_ns
= gfc_current_ns
;
5425 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
5427 gfc_current_ns
->sibling
= parent_ns
->contained
;
5428 parent_ns
->contained
= gfc_current_ns
;
5431 /* Process the next available statement. We come here if we got an error
5432 and rejected the last statement. */
5433 old_loc
= gfc_current_locus
;
5434 st
= next_statement ();
5443 contains_statements
= 1;
5444 accept_statement (st
);
5447 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
5450 /* For internal procedures, create/update the symbol in the
5451 parent namespace. */
5455 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
5456 gfc_error ("Contained procedure %qs at %C is already "
5457 "ambiguous", gfc_new_block
->name
);
5460 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
5462 &gfc_new_block
->declared_at
))
5464 if (st
== ST_FUNCTION
)
5465 gfc_add_function (&sym
->attr
, sym
->name
,
5466 &gfc_new_block
->declared_at
);
5468 gfc_add_subroutine (&sym
->attr
, sym
->name
,
5469 &gfc_new_block
->declared_at
);
5473 gfc_commit_symbols ();
5476 sym
= gfc_new_block
;
5478 /* Mark this as a contained function, so it isn't replaced
5479 by other module functions. */
5480 sym
->attr
.contained
= 1;
5482 /* Set implicit_pure so that it can be reset if any of the
5483 tests for purity fail. This is used for some optimisation
5484 during translation. */
5485 if (!sym
->attr
.pure
)
5486 sym
->attr
.implicit_pure
= 1;
5488 parse_progunit (ST_NONE
);
5490 /* Fix up any sibling functions that refer to this one. */
5491 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
5492 /* Or refer to any of its alternate entry points. */
5493 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
5494 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
5496 gfc_current_ns
->code
= s2
.head
;
5497 gfc_current_ns
= parent_ns
;
5502 /* These statements are associated with the end of the host unit. */
5503 case ST_END_FUNCTION
:
5505 case ST_END_SUBMODULE
:
5506 case ST_END_PROGRAM
:
5507 case ST_END_SUBROUTINE
:
5508 accept_statement (st
);
5509 gfc_current_ns
->code
= s1
.head
;
5513 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
5514 gfc_ascii_statement (st
));
5515 reject_statement ();
5521 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
5522 && st
!= ST_END_MODULE
&& st
!= ST_END_SUBMODULE
5523 && st
!= ST_END_PROGRAM
);
5525 /* The first namespace in the list is guaranteed to not have
5526 anything (worthwhile) in it. */
5527 tmp
= gfc_current_ns
;
5528 gfc_current_ns
= parent_ns
;
5529 if (seen_error
&& tmp
->refs
> 1)
5530 gfc_free_namespace (tmp
);
5532 ns
= gfc_current_ns
->contained
;
5533 gfc_current_ns
->contained
= ns
->sibling
;
5534 gfc_free_namespace (ns
);
5537 if (!contains_statements
)
5538 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
5539 "FUNCTION or SUBROUTINE statement at %L", &old_loc
);
5543 /* The result variable in a MODULE PROCEDURE needs to be created and
5544 its characteristics copied from the interface since it is neither
5545 declared in the procedure declaration nor in the specification
5549 get_modproc_result (void)
5552 if (gfc_state_stack
->previous
5553 && gfc_state_stack
->previous
->state
== COMP_CONTAINS
5554 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
5556 proc
= gfc_current_ns
->proc_name
? gfc_current_ns
->proc_name
: NULL
;
5558 && proc
->attr
.function
5560 && proc
->tlink
->result
5561 && proc
->tlink
->result
!= proc
->tlink
)
5563 gfc_copy_dummy_sym (&proc
->result
, proc
->tlink
->result
, 1);
5564 gfc_set_sym_referenced (proc
->result
);
5565 proc
->result
->attr
.if_source
= IFSRC_DECL
;
5566 gfc_commit_symbol (proc
->result
);
5572 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
5575 parse_progunit (gfc_statement st
)
5581 && gfc_new_block
->abr_modproc_decl
5582 && gfc_new_block
->attr
.function
)
5583 get_modproc_result ();
5585 st
= parse_spec (st
);
5592 /* This is not allowed within BLOCK! */
5593 if (gfc_current_state () != COMP_BLOCK
)
5598 accept_statement (st
);
5605 if (gfc_current_state () == COMP_FUNCTION
)
5606 gfc_check_function_type (gfc_current_ns
);
5611 st
= parse_executable (st
);
5619 /* This is not allowed within BLOCK! */
5620 if (gfc_current_state () != COMP_BLOCK
)
5625 accept_statement (st
);
5632 unexpected_statement (st
);
5633 reject_statement ();
5634 st
= next_statement ();
5640 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
5641 if (p
->state
== COMP_CONTAINS
)
5644 if (gfc_find_state (COMP_MODULE
) == true
5645 || gfc_find_state (COMP_SUBMODULE
) == true)
5650 gfc_error ("CONTAINS statement at %C is already in a contained "
5652 reject_statement ();
5653 st
= next_statement ();
5657 parse_contained (0);
5660 gfc_current_ns
->code
= gfc_state_stack
->head
;
5664 /* Come here to complain about a global symbol already in use as
5668 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
5673 where
= &gfc_current_locus
;
5683 case GSYM_SUBROUTINE
:
5684 name
= "SUBROUTINE";
5689 case GSYM_BLOCK_DATA
:
5690 name
= "BLOCK DATA";
5696 gfc_internal_error ("gfc_global_used(): Bad type");
5700 if (sym
->binding_label
)
5701 gfc_error ("Global binding name %qs at %L is already being used as a %s "
5702 "at %L", sym
->binding_label
, where
, name
, &sym
->where
);
5704 gfc_error ("Global name %qs at %L is already being used as a %s at %L",
5705 sym
->name
, where
, name
, &sym
->where
);
5709 /* Parse a block data program unit. */
5712 parse_block_data (void)
5715 static locus blank_locus
;
5716 static int blank_block
=0;
5719 gfc_current_ns
->proc_name
= gfc_new_block
;
5720 gfc_current_ns
->is_block_data
= 1;
5722 if (gfc_new_block
== NULL
)
5725 gfc_error ("Blank BLOCK DATA at %C conflicts with "
5726 "prior BLOCK DATA at %L", &blank_locus
);
5730 blank_locus
= gfc_current_locus
;
5735 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5737 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
5738 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5741 s
->type
= GSYM_BLOCK_DATA
;
5742 s
->where
= gfc_new_block
->declared_at
;
5747 st
= parse_spec (ST_NONE
);
5749 while (st
!= ST_END_BLOCK_DATA
)
5751 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
5752 gfc_ascii_statement (st
));
5753 reject_statement ();
5754 st
= next_statement ();
5759 /* Following the association of the ancestor (sub)module symbols, they
5760 must be set host rather than use associated and all must be public.
5761 They are flagged up by 'used_in_submodule' so that they can be set
5762 DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
5763 linker chokes on multiple symbol definitions. */
5766 set_syms_host_assoc (gfc_symbol
*sym
)
5773 if (sym
->attr
.module_procedure
)
5774 sym
->attr
.external
= 0;
5776 /* sym->attr.access = ACCESS_PUBLIC; */
5778 sym
->attr
.use_assoc
= 0;
5779 sym
->attr
.host_assoc
= 1;
5780 sym
->attr
.used_in_submodule
=1;
5782 if (sym
->attr
.flavor
== FL_DERIVED
)
5784 for (c
= sym
->components
; c
; c
= c
->next
)
5785 c
->attr
.access
= ACCESS_PUBLIC
;
5789 /* Parse a module subprogram. */
5798 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5799 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
5800 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5803 s
->type
= GSYM_MODULE
;
5804 s
->where
= gfc_new_block
->declared_at
;
5808 /* Something is nulling the module_list after this point. This is good
5809 since it allows us to 'USE' the parent modules that the submodule
5810 inherits and to set (most) of the symbols as host associated. */
5811 if (gfc_current_state () == COMP_SUBMODULE
)
5814 gfc_traverse_ns (gfc_current_ns
, set_syms_host_assoc
);
5817 st
= parse_spec (ST_NONE
);
5827 parse_contained (1);
5831 case ST_END_SUBMODULE
:
5832 accept_statement (st
);
5836 gfc_error ("Unexpected %s statement in MODULE at %C",
5837 gfc_ascii_statement (st
));
5840 reject_statement ();
5841 st
= next_statement ();
5845 /* Make sure not to free the namespace twice on error. */
5847 s
->ns
= gfc_current_ns
;
5851 /* Add a procedure name to the global symbol table. */
5854 add_global_procedure (bool sub
)
5858 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
5859 name is a global identifier. */
5860 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
5862 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5865 || (s
->type
!= GSYM_UNKNOWN
5866 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5868 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5869 /* Silence follow-up errors. */
5870 gfc_new_block
->binding_label
= NULL
;
5874 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5875 s
->sym_name
= gfc_new_block
->name
;
5876 s
->where
= gfc_new_block
->declared_at
;
5878 s
->ns
= gfc_current_ns
;
5882 /* Don't add the symbol multiple times. */
5883 if (gfc_new_block
->binding_label
5884 && (!gfc_notification_std (GFC_STD_F2008
)
5885 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
5887 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
);
5890 || (s
->type
!= GSYM_UNKNOWN
5891 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
5893 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5894 /* Silence follow-up errors. */
5895 gfc_new_block
->binding_label
= NULL
;
5899 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
5900 s
->sym_name
= gfc_new_block
->name
;
5901 s
->binding_label
= gfc_new_block
->binding_label
;
5902 s
->where
= gfc_new_block
->declared_at
;
5904 s
->ns
= gfc_current_ns
;
5910 /* Add a program to the global symbol table. */
5913 add_global_program (void)
5917 if (gfc_new_block
== NULL
)
5919 s
= gfc_get_gsymbol (gfc_new_block
->name
);
5921 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
5922 gfc_global_used (s
, &gfc_new_block
->declared_at
);
5925 s
->type
= GSYM_PROGRAM
;
5926 s
->where
= gfc_new_block
->declared_at
;
5928 s
->ns
= gfc_current_ns
;
5933 /* Resolve all the program units. */
5935 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
5937 gfc_free_dt_list ();
5938 gfc_current_ns
= gfc_global_ns_list
;
5939 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5941 if (gfc_current_ns
->proc_name
5942 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
5943 continue; /* Already resolved. */
5945 if (gfc_current_ns
->proc_name
)
5946 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5947 gfc_resolve (gfc_current_ns
);
5948 gfc_current_ns
->derived_types
= gfc_derived_types
;
5949 gfc_derived_types
= NULL
;
5955 clean_up_modules (gfc_gsymbol
*gsym
)
5960 clean_up_modules (gsym
->left
);
5961 clean_up_modules (gsym
->right
);
5963 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
5966 gfc_current_ns
= gsym
->ns
;
5967 gfc_derived_types
= gfc_current_ns
->derived_types
;
5974 /* Translate all the program units. This could be in a different order
5975 to resolution if there are forward references in the file. */
5977 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
5981 gfc_current_ns
= gfc_global_ns_list
;
5982 gfc_get_errors (NULL
, &errors
);
5984 /* We first translate all modules to make sure that later parts
5985 of the program can use the decl. Then we translate the nonmodules. */
5987 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
5989 if (!gfc_current_ns
->proc_name
5990 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
5993 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
5994 gfc_derived_types
= gfc_current_ns
->derived_types
;
5995 gfc_generate_module_code (gfc_current_ns
);
5996 gfc_current_ns
->translated
= 1;
5999 gfc_current_ns
= gfc_global_ns_list
;
6000 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6002 if (gfc_current_ns
->proc_name
6003 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6006 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6007 gfc_derived_types
= gfc_current_ns
->derived_types
;
6008 gfc_generate_code (gfc_current_ns
);
6009 gfc_current_ns
->translated
= 1;
6012 /* Clean up all the namespaces after translation. */
6013 gfc_current_ns
= gfc_global_ns_list
;
6014 for (;gfc_current_ns
;)
6018 if (gfc_current_ns
->proc_name
6019 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6021 gfc_current_ns
= gfc_current_ns
->sibling
;
6025 ns
= gfc_current_ns
->sibling
;
6026 gfc_derived_types
= gfc_current_ns
->derived_types
;
6028 gfc_current_ns
= ns
;
6031 clean_up_modules (gfc_gsym_root
);
6035 /* Top level parser. */
6038 gfc_parse_file (void)
6040 int seen_program
, errors_before
, errors
;
6041 gfc_state_data top
, s
;
6044 gfc_namespace
*next
;
6046 gfc_start_source_files ();
6048 top
.state
= COMP_NONE
;
6050 top
.previous
= NULL
;
6051 top
.head
= top
.tail
= NULL
;
6052 top
.do_variable
= NULL
;
6054 gfc_state_stack
= &top
;
6056 gfc_clear_new_st ();
6058 gfc_statement_label
= NULL
;
6060 if (setjmp (eof_buf
))
6061 return false; /* Come here on unexpected EOF */
6063 /* Prepare the global namespace that will contain the
6065 gfc_global_ns_list
= next
= NULL
;
6070 /* Exit early for empty files. */
6074 in_specification_block
= true;
6077 st
= next_statement ();
6086 goto duplicate_main
;
6088 prog_locus
= gfc_current_locus
;
6090 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
6091 main_program_symbol (gfc_current_ns
, gfc_new_block
->name
);
6092 accept_statement (st
);
6093 add_global_program ();
6094 parse_progunit (ST_NONE
);
6098 add_global_procedure (true);
6099 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
6100 accept_statement (st
);
6101 parse_progunit (ST_NONE
);
6105 add_global_procedure (false);
6106 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
6107 accept_statement (st
);
6108 parse_progunit (ST_NONE
);
6112 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
6113 accept_statement (st
);
6114 parse_block_data ();
6118 push_state (&s
, COMP_MODULE
, gfc_new_block
);
6119 accept_statement (st
);
6121 gfc_get_errors (NULL
, &errors_before
);
6126 push_state (&s
, COMP_SUBMODULE
, gfc_new_block
);
6127 accept_statement (st
);
6129 gfc_get_errors (NULL
, &errors_before
);
6133 /* Anything else starts a nameless main program block. */
6136 goto duplicate_main
;
6138 prog_locus
= gfc_current_locus
;
6140 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
6141 main_program_symbol (gfc_current_ns
, "MAIN__");
6142 parse_progunit (st
);
6146 /* Handle the non-program units. */
6147 gfc_current_ns
->code
= s
.head
;
6149 gfc_resolve (gfc_current_ns
);
6151 /* Dump the parse tree if requested. */
6152 if (flag_dump_fortran_original
)
6153 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6155 gfc_get_errors (NULL
, &errors
);
6156 if (s
.state
== COMP_MODULE
|| s
.state
== COMP_SUBMODULE
)
6158 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
6159 gfc_current_ns
->derived_types
= gfc_derived_types
;
6160 gfc_derived_types
= NULL
;
6166 gfc_generate_code (gfc_current_ns
);
6174 /* The main program and non-contained procedures are put
6175 in the global namespace list, so that they can be processed
6176 later and all their interfaces resolved. */
6177 gfc_current_ns
->code
= s
.head
;
6180 for (; next
->sibling
; next
= next
->sibling
)
6182 next
->sibling
= gfc_current_ns
;
6185 gfc_global_ns_list
= gfc_current_ns
;
6187 next
= gfc_current_ns
;
6193 /* Do the resolution. */
6194 resolve_all_program_units (gfc_global_ns_list
);
6196 /* Do the parse tree dump. */
6197 gfc_current_ns
= flag_dump_fortran_original
? gfc_global_ns_list
: NULL
;
6199 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6200 if (!gfc_current_ns
->proc_name
6201 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6203 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6204 fputs ("------------------------------------------\n\n", stdout
);
6207 /* Do the translation. */
6208 translate_all_program_units (gfc_global_ns_list
);
6210 gfc_end_source_files ();
6214 /* If we see a duplicate main program, shut down. If the second
6215 instance is an implied main program, i.e. data decls or executable
6216 statements, we're in for lots of errors. */
6217 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
6218 reject_statement ();
6223 /* Return true if this state data represents an OpenACC region. */
6225 is_oacc (gfc_state_data
*sd
)
6227 switch (sd
->construct
->op
)
6229 case EXEC_OACC_PARALLEL_LOOP
:
6230 case EXEC_OACC_PARALLEL
:
6231 case EXEC_OACC_KERNELS_LOOP
:
6232 case EXEC_OACC_KERNELS
:
6233 case EXEC_OACC_DATA
:
6234 case EXEC_OACC_HOST_DATA
:
6235 case EXEC_OACC_LOOP
:
6236 case EXEC_OACC_UPDATE
:
6237 case EXEC_OACC_WAIT
:
6238 case EXEC_OACC_CACHE
:
6239 case EXEC_OACC_ENTER_DATA
:
6240 case EXEC_OACC_EXIT_DATA
:
6241 case EXEC_OACC_ATOMIC
:
6242 case EXEC_OACC_ROUTINE
: