2 Copyright (C) 2000-2020 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
);
429 match (NULL
, gfc_match_select_rank
, ST_SELECT_RANK
);
431 /* General statement matching: Instead of testing every possible
432 statement, we eliminate most possibilities by peeking at the
438 match ("abstract% interface", gfc_match_abstract_interface
,
440 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
441 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
442 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
443 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
444 match ("automatic", gfc_match_automatic
, ST_ATTR_DECL
);
448 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
449 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
450 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
454 match ("call", gfc_match_call
, ST_CALL
);
455 match ("change team", gfc_match_change_team
, ST_CHANGE_TEAM
);
456 match ("close", gfc_match_close
, ST_CLOSE
);
457 match ("continue", gfc_match_continue
, ST_CONTINUE
);
458 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
459 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
460 match ("case", gfc_match_case
, ST_CASE
);
461 match ("common", gfc_match_common
, ST_COMMON
);
462 match ("contains", gfc_match_eos
, ST_CONTAINS
);
463 match ("class", gfc_match_class_is
, ST_CLASS_IS
);
464 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
468 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
469 match ("data", gfc_match_data
, ST_DATA
);
470 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
474 match ("end file", gfc_match_endfile
, ST_END_FILE
);
475 match ("end team", gfc_match_end_team
, ST_END_TEAM
);
476 match ("exit", gfc_match_exit
, ST_EXIT
);
477 match ("else", gfc_match_else
, ST_ELSE
);
478 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
479 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
480 match ("error stop", gfc_match_error_stop
, ST_ERROR_STOP
);
481 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
483 if (gfc_match_end (&st
) == MATCH_YES
)
486 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
487 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
488 match ("external", gfc_match_external
, ST_ATTR_DECL
);
489 match ("event post", gfc_match_event_post
, ST_EVENT_POST
);
490 match ("event wait", gfc_match_event_wait
, ST_EVENT_WAIT
);
494 match ("fail image", gfc_match_fail_image
, ST_FAIL_IMAGE
);
495 match ("final", gfc_match_final_decl
, ST_FINAL
);
496 match ("flush", gfc_match_flush
, ST_FLUSH
);
497 match ("form team", gfc_match_form_team
, ST_FORM_TEAM
);
498 match ("format", gfc_match_format
, ST_FORMAT
);
502 match ("generic", gfc_match_generic
, ST_GENERIC
);
503 match ("go to", gfc_match_goto
, ST_GOTO
);
507 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
508 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
509 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
510 match ("import", gfc_match_import
, ST_IMPORT
);
511 match ("interface", gfc_match_interface
, ST_INTERFACE
);
512 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
513 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
517 match ("lock", gfc_match_lock
, ST_LOCK
);
521 match ("map", gfc_match_map
, ST_MAP
);
522 match ("module% procedure", gfc_match_modproc
, ST_MODULE_PROC
);
523 match ("module", gfc_match_module
, ST_MODULE
);
527 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
528 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
532 match ("open", gfc_match_open
, ST_OPEN
);
533 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
537 match ("print", gfc_match_print
, ST_WRITE
);
538 match ("pause", gfc_match_pause
, ST_PAUSE
);
539 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
540 if (gfc_match_private (&st
) == MATCH_YES
)
542 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
543 match ("program", gfc_match_program
, ST_PROGRAM
);
544 if (gfc_match_public (&st
) == MATCH_YES
)
546 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
550 match ("rank", gfc_match_rank_is
, ST_RANK
);
551 match ("read", gfc_match_read
, ST_READ
);
552 match ("return", gfc_match_return
, ST_RETURN
);
553 match ("rewind", gfc_match_rewind
, ST_REWIND
);
557 match ("structure", gfc_match_structure_decl
, ST_STRUCTURE_DECL
);
558 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
559 match ("stop", gfc_match_stop
, ST_STOP
);
560 match ("save", gfc_match_save
, ST_ATTR_DECL
);
561 match ("static", gfc_match_static
, ST_ATTR_DECL
);
562 match ("submodule", gfc_match_submodule
, ST_SUBMODULE
);
563 match ("sync all", gfc_match_sync_all
, ST_SYNC_ALL
);
564 match ("sync images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
565 match ("sync memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
566 match ("sync team", gfc_match_sync_team
, ST_SYNC_TEAM
);
570 match ("target", gfc_match_target
, ST_ATTR_DECL
);
571 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
572 match ("type is", gfc_match_type_is
, ST_TYPE_IS
);
576 match ("union", gfc_match_union
, ST_UNION
);
577 match ("unlock", gfc_match_unlock
, ST_UNLOCK
);
581 match ("value", gfc_match_value
, ST_ATTR_DECL
);
582 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
586 match ("wait", gfc_match_wait
, ST_WAIT
);
587 match ("write", gfc_match_write
, ST_WRITE
);
591 /* All else has failed, so give up. See if any of the matchers has
592 stored an error message of some sort. Suppress the "Unclassifiable
593 statement" if a previous error message was emitted, e.g., by
595 if (!gfc_error_check ())
598 gfc_get_errors (NULL
, &ecnt
);
600 gfc_error_now ("Unclassifiable statement at %C");
605 gfc_error_recovery ();
610 /* Like match and if spec_only, goto do_spec_only without actually
612 /* If the directive matched but the clauses failed, do not start
613 matching the next directive in the same switch statement. */
614 #define matcha(keyword, subr, st) \
617 if (spec_only && gfc_match (keyword) == MATCH_YES) \
619 else if ((m2 = match_word (keyword, subr, &old_locus)) \
622 else if (m2 == MATCH_ERROR) \
623 goto error_handling; \
625 undo_new_statement (); \
629 decode_oacc_directive (void)
633 bool spec_only
= false;
635 gfc_enforce_clean_symbol_state ();
637 gfc_clear_error (); /* Clear any pending errors. */
638 gfc_clear_warning (); /* Clear any pending warnings. */
640 gfc_matching_function
= false;
644 gfc_error_now ("OpenACC directives at %C may not appear in PURE "
646 gfc_error_recovery ();
650 if (gfc_current_state () == COMP_FUNCTION
651 && gfc_current_block ()->result
->ts
.kind
== -1)
654 gfc_unset_implicit_pure (NULL
);
656 old_locus
= gfc_current_locus
;
658 /* General OpenACC directive matching: Instead of testing every possible
659 statement, we eliminate most possibilities by peeking at the
662 c
= gfc_peek_ascii_char ();
667 matcha ("atomic", gfc_match_oacc_atomic
, ST_OACC_ATOMIC
);
670 matcha ("cache", gfc_match_oacc_cache
, ST_OACC_CACHE
);
673 matcha ("data", gfc_match_oacc_data
, ST_OACC_DATA
);
674 match ("declare", gfc_match_oacc_declare
, ST_OACC_DECLARE
);
677 matcha ("end atomic", gfc_match_omp_eos_error
, ST_OACC_END_ATOMIC
);
678 matcha ("end data", gfc_match_omp_eos_error
, ST_OACC_END_DATA
);
679 matcha ("end host_data", gfc_match_omp_eos_error
, ST_OACC_END_HOST_DATA
);
680 matcha ("end kernels loop", gfc_match_omp_eos_error
, ST_OACC_END_KERNELS_LOOP
);
681 matcha ("end kernels", gfc_match_omp_eos_error
, ST_OACC_END_KERNELS
);
682 matcha ("end loop", gfc_match_omp_eos_error
, ST_OACC_END_LOOP
);
683 matcha ("end parallel loop", gfc_match_omp_eos_error
,
684 ST_OACC_END_PARALLEL_LOOP
);
685 matcha ("end parallel", gfc_match_omp_eos_error
, ST_OACC_END_PARALLEL
);
686 matcha ("end serial loop", gfc_match_omp_eos_error
,
687 ST_OACC_END_SERIAL_LOOP
);
688 matcha ("end serial", gfc_match_omp_eos_error
, ST_OACC_END_SERIAL
);
689 matcha ("enter data", gfc_match_oacc_enter_data
, ST_OACC_ENTER_DATA
);
690 matcha ("exit data", gfc_match_oacc_exit_data
, ST_OACC_EXIT_DATA
);
693 matcha ("host_data", gfc_match_oacc_host_data
, ST_OACC_HOST_DATA
);
696 matcha ("parallel loop", gfc_match_oacc_parallel_loop
,
697 ST_OACC_PARALLEL_LOOP
);
698 matcha ("parallel", gfc_match_oacc_parallel
, ST_OACC_PARALLEL
);
701 matcha ("kernels loop", gfc_match_oacc_kernels_loop
,
702 ST_OACC_KERNELS_LOOP
);
703 matcha ("kernels", gfc_match_oacc_kernels
, ST_OACC_KERNELS
);
706 matcha ("loop", gfc_match_oacc_loop
, ST_OACC_LOOP
);
709 match ("routine", gfc_match_oacc_routine
, ST_OACC_ROUTINE
);
712 matcha ("serial loop", gfc_match_oacc_serial_loop
, ST_OACC_SERIAL_LOOP
);
713 matcha ("serial", gfc_match_oacc_serial
, ST_OACC_SERIAL
);
716 matcha ("update", gfc_match_oacc_update
, ST_OACC_UPDATE
);
719 matcha ("wait", gfc_match_oacc_wait
, ST_OACC_WAIT
);
723 /* Directive not found or stored an error message.
724 Check and give up. */
727 if (gfc_error_check () == 0)
728 gfc_error_now ("Unclassifiable OpenACC directive at %C");
732 gfc_error_recovery ();
739 gfc_buffer_error (false);
740 gfc_current_locus
= old_locus
;
741 return ST_GET_FCN_CHARACTERISTICS
;
744 /* Like match, but set a flag simd_matched if keyword matched
745 and if spec_only, goto do_spec_only without actually matching. */
746 #define matchs(keyword, subr, st) \
749 if (spec_only && gfc_match (keyword) == MATCH_YES) \
751 if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \
752 &simd_matched)) == MATCH_YES) \
757 else if (m2 == MATCH_ERROR) \
758 goto error_handling; \
760 undo_new_statement (); \
763 /* Like match, but don't match anything if not -fopenmp
764 and if spec_only, goto do_spec_only without actually matching. */
765 /* If the directive matched but the clauses failed, do not start
766 matching the next directive in the same switch statement. */
767 #define matcho(keyword, subr, st) \
772 else if (spec_only && gfc_match (keyword) == MATCH_YES) \
774 else if ((m2 = match_word (keyword, subr, &old_locus)) \
780 else if (m2 == MATCH_ERROR) \
781 goto error_handling; \
783 undo_new_statement (); \
786 /* Like match, but set a flag simd_matched if keyword matched. */
787 #define matchds(keyword, subr, st) \
790 if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \
791 &simd_matched)) == MATCH_YES) \
796 else if (m2 == MATCH_ERROR) \
797 goto error_handling; \
799 undo_new_statement (); \
802 /* Like match, but don't match anything if not -fopenmp. */
803 #define matchdo(keyword, subr, st) \
808 else if ((m2 = match_word (keyword, subr, &old_locus)) \
814 else if (m2 == MATCH_ERROR) \
815 goto error_handling; \
817 undo_new_statement (); \
821 decode_omp_directive (void)
825 bool simd_matched
= false;
826 bool spec_only
= false;
827 gfc_statement ret
= ST_NONE
;
830 gfc_enforce_clean_symbol_state ();
832 gfc_clear_error (); /* Clear any pending errors. */
833 gfc_clear_warning (); /* Clear any pending warnings. */
835 gfc_matching_function
= false;
837 if (gfc_current_state () == COMP_FUNCTION
838 && gfc_current_block ()->result
->ts
.kind
== -1)
841 old_locus
= gfc_current_locus
;
843 /* General OpenMP directive matching: Instead of testing every possible
844 statement, we eliminate most possibilities by peeking at the
847 c
= gfc_peek_ascii_char ();
849 /* match is for directives that should be recognized only if
850 -fopenmp, matchs for directives that should be recognized
851 if either -fopenmp or -fopenmp-simd.
852 Handle only the directives allowed in PURE/ELEMENTAL procedures
853 first (those also shall not turn off implicit pure). */
857 matchds ("declare simd", gfc_match_omp_declare_simd
,
858 ST_OMP_DECLARE_SIMD
);
859 matchdo ("declare target", gfc_match_omp_declare_target
,
860 ST_OMP_DECLARE_TARGET
);
863 matchs ("simd", gfc_match_omp_simd
, ST_OMP_SIMD
);
868 if (flag_openmp
&& gfc_pure (NULL
))
870 gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET "
871 "at %C may not appear in PURE or ELEMENTAL procedures");
872 gfc_error_recovery ();
876 /* match is for directives that should be recognized only if
877 -fopenmp, matchs for directives that should be recognized
878 if either -fopenmp or -fopenmp-simd. */
882 matcho ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
885 matcho ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
888 matcho ("cancellation% point", gfc_match_omp_cancellation_point
,
889 ST_OMP_CANCELLATION_POINT
);
890 matcho ("cancel", gfc_match_omp_cancel
, ST_OMP_CANCEL
);
891 matcho ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
894 matchds ("declare reduction", gfc_match_omp_declare_reduction
,
895 ST_OMP_DECLARE_REDUCTION
);
896 matchs ("distribute parallel do simd",
897 gfc_match_omp_distribute_parallel_do_simd
,
898 ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
);
899 matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do
,
900 ST_OMP_DISTRIBUTE_PARALLEL_DO
);
901 matchs ("distribute simd", gfc_match_omp_distribute_simd
,
902 ST_OMP_DISTRIBUTE_SIMD
);
903 matcho ("distribute", gfc_match_omp_distribute
, ST_OMP_DISTRIBUTE
);
904 matchs ("do simd", gfc_match_omp_do_simd
, ST_OMP_DO_SIMD
);
905 matcho ("do", gfc_match_omp_do
, ST_OMP_DO
);
908 matcho ("end atomic", gfc_match_omp_eos_error
, ST_OMP_END_ATOMIC
);
909 matcho ("end critical", gfc_match_omp_end_critical
, ST_OMP_END_CRITICAL
);
910 matchs ("end distribute parallel do simd", gfc_match_omp_eos_error
,
911 ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
);
912 matcho ("end distribute parallel do", gfc_match_omp_eos_error
,
913 ST_OMP_END_DISTRIBUTE_PARALLEL_DO
);
914 matchs ("end distribute simd", gfc_match_omp_eos_error
,
915 ST_OMP_END_DISTRIBUTE_SIMD
);
916 matcho ("end distribute", gfc_match_omp_eos_error
, ST_OMP_END_DISTRIBUTE
);
917 matchs ("end do simd", gfc_match_omp_end_nowait
, ST_OMP_END_DO_SIMD
);
918 matcho ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
919 matchs ("end simd", gfc_match_omp_eos_error
, ST_OMP_END_SIMD
);
920 matcho ("end master", gfc_match_omp_eos_error
, ST_OMP_END_MASTER
);
921 matchs ("end ordered", gfc_match_omp_eos_error
, ST_OMP_END_ORDERED
);
922 matchs ("end parallel do simd", gfc_match_omp_eos_error
,
923 ST_OMP_END_PARALLEL_DO_SIMD
);
924 matcho ("end parallel do", gfc_match_omp_eos_error
, ST_OMP_END_PARALLEL_DO
);
925 matcho ("end parallel sections", gfc_match_omp_eos_error
,
926 ST_OMP_END_PARALLEL_SECTIONS
);
927 matcho ("end parallel workshare", gfc_match_omp_eos_error
,
928 ST_OMP_END_PARALLEL_WORKSHARE
);
929 matcho ("end parallel", gfc_match_omp_eos_error
, ST_OMP_END_PARALLEL
);
930 matcho ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
931 matcho ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
932 matcho ("end target data", gfc_match_omp_eos_error
, ST_OMP_END_TARGET_DATA
);
933 matchs ("end target parallel do simd", gfc_match_omp_eos_error
,
934 ST_OMP_END_TARGET_PARALLEL_DO_SIMD
);
935 matcho ("end target parallel do", gfc_match_omp_eos_error
,
936 ST_OMP_END_TARGET_PARALLEL_DO
);
937 matcho ("end target parallel", gfc_match_omp_eos_error
,
938 ST_OMP_END_TARGET_PARALLEL
);
939 matchs ("end target simd", gfc_match_omp_eos_error
, ST_OMP_END_TARGET_SIMD
);
940 matchs ("end target teams distribute parallel do simd",
941 gfc_match_omp_eos_error
,
942 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
943 matcho ("end target teams distribute parallel do", gfc_match_omp_eos_error
,
944 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
945 matchs ("end target teams distribute simd", gfc_match_omp_eos_error
,
946 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
);
947 matcho ("end target teams distribute", gfc_match_omp_eos_error
,
948 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
);
949 matcho ("end target teams", gfc_match_omp_eos_error
, ST_OMP_END_TARGET_TEAMS
);
950 matcho ("end target", gfc_match_omp_eos_error
, ST_OMP_END_TARGET
);
951 matcho ("end taskgroup", gfc_match_omp_eos_error
, ST_OMP_END_TASKGROUP
);
952 matchs ("end taskloop simd", gfc_match_omp_eos_error
,
953 ST_OMP_END_TASKLOOP_SIMD
);
954 matcho ("end taskloop", gfc_match_omp_eos_error
, ST_OMP_END_TASKLOOP
);
955 matcho ("end task", gfc_match_omp_eos_error
, ST_OMP_END_TASK
);
956 matchs ("end teams distribute parallel do simd", gfc_match_omp_eos_error
,
957 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
958 matcho ("end teams distribute parallel do", gfc_match_omp_eos_error
,
959 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
);
960 matchs ("end teams distribute simd", gfc_match_omp_eos_error
,
961 ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
);
962 matcho ("end teams distribute", gfc_match_omp_eos_error
,
963 ST_OMP_END_TEAMS_DISTRIBUTE
);
964 matcho ("end teams", gfc_match_omp_eos_error
, ST_OMP_END_TEAMS
);
965 matcho ("end workshare", gfc_match_omp_end_nowait
,
966 ST_OMP_END_WORKSHARE
);
969 matcho ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
972 matcho ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
975 if (gfc_match ("ordered depend (") == MATCH_YES
)
977 gfc_current_locus
= old_locus
;
980 matcho ("ordered", gfc_match_omp_ordered_depend
,
981 ST_OMP_ORDERED_DEPEND
);
984 matchs ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
987 matchs ("parallel do simd", gfc_match_omp_parallel_do_simd
,
988 ST_OMP_PARALLEL_DO_SIMD
);
989 matcho ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
990 matcho ("parallel sections", gfc_match_omp_parallel_sections
,
991 ST_OMP_PARALLEL_SECTIONS
);
992 matcho ("parallel workshare", gfc_match_omp_parallel_workshare
,
993 ST_OMP_PARALLEL_WORKSHARE
);
994 matcho ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
997 matcho ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
998 matcho ("section", gfc_match_omp_eos_error
, ST_OMP_SECTION
);
999 matcho ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
1002 matcho ("target data", gfc_match_omp_target_data
, ST_OMP_TARGET_DATA
);
1003 matcho ("target enter data", gfc_match_omp_target_enter_data
,
1004 ST_OMP_TARGET_ENTER_DATA
);
1005 matcho ("target exit data", gfc_match_omp_target_exit_data
,
1006 ST_OMP_TARGET_EXIT_DATA
);
1007 matchs ("target parallel do simd", gfc_match_omp_target_parallel_do_simd
,
1008 ST_OMP_TARGET_PARALLEL_DO_SIMD
);
1009 matcho ("target parallel do", gfc_match_omp_target_parallel_do
,
1010 ST_OMP_TARGET_PARALLEL_DO
);
1011 matcho ("target parallel", gfc_match_omp_target_parallel
,
1012 ST_OMP_TARGET_PARALLEL
);
1013 matchs ("target simd", gfc_match_omp_target_simd
, ST_OMP_TARGET_SIMD
);
1014 matchs ("target teams distribute parallel do simd",
1015 gfc_match_omp_target_teams_distribute_parallel_do_simd
,
1016 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
1017 matcho ("target teams distribute parallel do",
1018 gfc_match_omp_target_teams_distribute_parallel_do
,
1019 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
1020 matchs ("target teams distribute simd",
1021 gfc_match_omp_target_teams_distribute_simd
,
1022 ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
);
1023 matcho ("target teams distribute", gfc_match_omp_target_teams_distribute
,
1024 ST_OMP_TARGET_TEAMS_DISTRIBUTE
);
1025 matcho ("target teams", gfc_match_omp_target_teams
, ST_OMP_TARGET_TEAMS
);
1026 matcho ("target update", gfc_match_omp_target_update
,
1027 ST_OMP_TARGET_UPDATE
);
1028 matcho ("target", gfc_match_omp_target
, ST_OMP_TARGET
);
1029 matcho ("taskgroup", gfc_match_omp_taskgroup
, ST_OMP_TASKGROUP
);
1030 matchs ("taskloop simd", gfc_match_omp_taskloop_simd
,
1031 ST_OMP_TASKLOOP_SIMD
);
1032 matcho ("taskloop", gfc_match_omp_taskloop
, ST_OMP_TASKLOOP
);
1033 matcho ("taskwait", gfc_match_omp_taskwait
, ST_OMP_TASKWAIT
);
1034 matcho ("taskyield", gfc_match_omp_taskyield
, ST_OMP_TASKYIELD
);
1035 matcho ("task", gfc_match_omp_task
, ST_OMP_TASK
);
1036 matchs ("teams distribute parallel do simd",
1037 gfc_match_omp_teams_distribute_parallel_do_simd
,
1038 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
1039 matcho ("teams distribute parallel do",
1040 gfc_match_omp_teams_distribute_parallel_do
,
1041 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
);
1042 matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd
,
1043 ST_OMP_TEAMS_DISTRIBUTE_SIMD
);
1044 matcho ("teams distribute", gfc_match_omp_teams_distribute
,
1045 ST_OMP_TEAMS_DISTRIBUTE
);
1046 matcho ("teams", gfc_match_omp_teams
, ST_OMP_TEAMS
);
1047 matchdo ("threadprivate", gfc_match_omp_threadprivate
,
1048 ST_OMP_THREADPRIVATE
);
1051 matcho ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
1055 /* All else has failed, so give up. See if any of the matchers has
1056 stored an error message of some sort. Don't error out if
1057 not -fopenmp and simd_matched is false, i.e. if a directive other
1058 than one marked with match has been seen. */
1061 if (flag_openmp
|| simd_matched
)
1063 if (!gfc_error_check ())
1064 gfc_error_now ("Unclassifiable OpenMP directive at %C");
1067 reject_statement ();
1069 gfc_error_recovery ();
1076 gfc_unset_implicit_pure (NULL
);
1078 if (!flag_openmp
&& gfc_pure (NULL
))
1080 gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET "
1081 "at %C may not appear in PURE or ELEMENTAL "
1083 reject_statement ();
1084 gfc_error_recovery ();
1091 reject_statement ();
1093 gfc_buffer_error (false);
1094 gfc_current_locus
= old_locus
;
1095 return ST_GET_FCN_CHARACTERISTICS
;
1098 static gfc_statement
1099 decode_gcc_attribute (void)
1103 gfc_enforce_clean_symbol_state ();
1105 gfc_clear_error (); /* Clear any pending errors. */
1106 gfc_clear_warning (); /* Clear any pending warnings. */
1107 old_locus
= gfc_current_locus
;
1109 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
1110 match ("unroll", gfc_match_gcc_unroll
, ST_NONE
);
1111 match ("builtin", gfc_match_gcc_builtin
, ST_NONE
);
1112 match ("ivdep", gfc_match_gcc_ivdep
, ST_NONE
);
1113 match ("vector", gfc_match_gcc_vector
, ST_NONE
);
1114 match ("novector", gfc_match_gcc_novector
, ST_NONE
);
1116 /* All else has failed, so give up. See if any of the matchers has
1117 stored an error message of some sort. */
1119 if (!gfc_error_check ())
1122 gfc_error_now ("Unclassifiable GCC directive at %C");
1124 gfc_warning_now (0, "Unclassifiable GCC directive at %C, ignored");
1127 reject_statement ();
1129 gfc_error_recovery ();
1136 /* Assert next length characters to be equal to token in free form. */
1139 verify_token_free (const char* token
, int length
, bool last_was_use_stmt
)
1144 c
= gfc_next_ascii_char ();
1145 for (i
= 0; i
< length
; i
++, c
= gfc_next_ascii_char ())
1146 gcc_assert (c
== token
[i
]);
1148 gcc_assert (gfc_is_whitespace(c
));
1149 gfc_gobble_whitespace ();
1150 if (last_was_use_stmt
)
1154 /* Get the next statement in free form source. */
1156 static gfc_statement
1163 at_bol
= gfc_at_bol ();
1164 gfc_gobble_whitespace ();
1166 c
= gfc_peek_ascii_char ();
1172 /* Found a statement label? */
1173 m
= gfc_match_st_label (&gfc_statement_label
);
1175 d
= gfc_peek_ascii_char ();
1176 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
1178 gfc_match_small_literal_int (&i
, &cnt
);
1181 gfc_error_now ("Too many digits in statement label at %C");
1184 gfc_error_now ("Zero is not a valid statement label at %C");
1187 c
= gfc_next_ascii_char ();
1190 if (!gfc_is_whitespace (c
))
1191 gfc_error_now ("Non-numeric character in statement label at %C");
1197 label_locus
= gfc_current_locus
;
1199 gfc_gobble_whitespace ();
1201 if (at_bol
&& gfc_peek_ascii_char () == ';')
1203 gfc_error_now ("Semicolon at %C needs to be preceded by "
1205 gfc_next_ascii_char (); /* Eat up the semicolon. */
1209 if (gfc_match_eos () == MATCH_YES
)
1210 gfc_error_now ("Statement label without statement at %L",
1216 /* Comments have already been skipped by the time we get here,
1217 except for GCC attributes and OpenMP/OpenACC directives. */
1219 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
1220 c
= gfc_peek_ascii_char ();
1226 c
= gfc_next_ascii_char ();
1227 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
1228 gcc_assert (c
== "gcc$"[i
]);
1230 gfc_gobble_whitespace ();
1231 return decode_gcc_attribute ();
1236 /* Since both OpenMP and OpenACC directives starts with
1237 !$ character sequence, we must check all flags combinations */
1238 if ((flag_openmp
|| flag_openmp_simd
)
1241 verify_token_free ("$omp", 4, last_was_use_stmt
);
1242 return decode_omp_directive ();
1244 else if ((flag_openmp
|| flag_openmp_simd
)
1247 gfc_next_ascii_char (); /* Eat up dollar character */
1248 c
= gfc_peek_ascii_char ();
1252 verify_token_free ("omp", 3, last_was_use_stmt
);
1253 return decode_omp_directive ();
1257 verify_token_free ("acc", 3, last_was_use_stmt
);
1258 return decode_oacc_directive ();
1261 else if (flag_openacc
)
1263 verify_token_free ("$acc", 4, last_was_use_stmt
);
1264 return decode_oacc_directive ();
1270 if (at_bol
&& c
== ';')
1272 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1273 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1275 gfc_next_ascii_char (); /* Eat up the semicolon. */
1279 return decode_statement ();
1282 /* Assert next length characters to be equal to token in fixed form. */
1285 verify_token_fixed (const char *token
, int length
, bool last_was_use_stmt
)
1288 char c
= gfc_next_char_literal (NONSTRING
);
1290 for (i
= 0; i
< length
; i
++, c
= gfc_next_char_literal (NONSTRING
))
1291 gcc_assert ((char) gfc_wide_tolower (c
) == token
[i
]);
1293 if (c
!= ' ' && c
!= '0')
1295 gfc_buffer_error (false);
1296 gfc_error ("Bad continuation line at %C");
1299 if (last_was_use_stmt
)
1305 /* Get the next statement in fixed-form source. */
1307 static gfc_statement
1310 int label
, digit_flag
, i
;
1315 return decode_statement ();
1317 /* Skip past the current label field, parsing a statement label if
1318 one is there. This is a weird number parser, since the number is
1319 contained within five columns and can have any kind of embedded
1320 spaces. We also check for characters that make the rest of the
1326 for (i
= 0; i
< 5; i
++)
1328 c
= gfc_next_char_literal (NONSTRING
);
1345 label
= label
* 10 + ((unsigned char) c
- '0');
1346 label_locus
= gfc_current_locus
;
1350 /* Comments have already been skipped by the time we get
1351 here, except for GCC attributes and OpenMP directives. */
1354 c
= gfc_next_char_literal (NONSTRING
);
1356 if (TOLOWER (c
) == 'g')
1358 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
1359 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
1361 return decode_gcc_attribute ();
1365 if ((flag_openmp
|| flag_openmp_simd
)
1368 if (!verify_token_fixed ("omp", 3, last_was_use_stmt
))
1370 return decode_omp_directive ();
1372 else if ((flag_openmp
|| flag_openmp_simd
)
1375 c
= gfc_next_char_literal(NONSTRING
);
1376 if (c
== 'o' || c
== 'O')
1378 if (!verify_token_fixed ("mp", 2, last_was_use_stmt
))
1380 return decode_omp_directive ();
1382 else if (c
== 'a' || c
== 'A')
1384 if (!verify_token_fixed ("cc", 2, last_was_use_stmt
))
1386 return decode_oacc_directive ();
1389 else if (flag_openacc
)
1391 if (!verify_token_fixed ("acc", 3, last_was_use_stmt
))
1393 return decode_oacc_directive ();
1398 /* Comments have already been skipped by the time we get
1399 here so don't bother checking for them. */
1402 gfc_buffer_error (false);
1403 gfc_error ("Non-numeric character in statement label at %C");
1411 gfc_warning_now (0, "Zero is not a valid statement label at %C");
1414 /* We've found a valid statement label. */
1415 gfc_statement_label
= gfc_get_st_label (label
);
1419 /* Since this line starts a statement, it cannot be a continuation
1420 of a previous statement. If we see something here besides a
1421 space or zero, it must be a bad continuation line. */
1423 c
= gfc_next_char_literal (NONSTRING
);
1427 if (c
!= ' ' && c
!= '0')
1429 gfc_buffer_error (false);
1430 gfc_error ("Bad continuation line at %C");
1434 /* Now that we've taken care of the statement label columns, we have
1435 to make sure that the first nonblank character is not a '!'. If
1436 it is, the rest of the line is a comment. */
1440 loc
= gfc_current_locus
;
1441 c
= gfc_next_char_literal (NONSTRING
);
1443 while (gfc_is_whitespace (c
));
1447 gfc_current_locus
= loc
;
1452 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1453 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1454 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1459 if (gfc_match_eos () == MATCH_YES
)
1462 /* At this point, we've got a nonblank statement to parse. */
1463 return decode_statement ();
1467 gfc_error_now ("Statement label without statement at %L", &label_locus
);
1469 gfc_current_locus
.lb
->truncated
= 0;
1470 gfc_advance_line ();
1475 /* Return the next non-ST_NONE statement to the caller. We also worry
1476 about including files and the ends of include files at this stage. */
1478 static gfc_statement
1479 next_statement (void)
1484 gfc_enforce_clean_symbol_state ();
1486 gfc_new_block
= NULL
;
1488 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1489 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
1492 gfc_statement_label
= NULL
;
1493 gfc_buffer_error (true);
1496 gfc_advance_line ();
1498 gfc_skip_comments ();
1506 if (gfc_define_undef_line ())
1509 old_locus
= gfc_current_locus
;
1511 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1517 gfc_buffer_error (false);
1519 if (st
== ST_GET_FCN_CHARACTERISTICS
)
1521 if (gfc_statement_label
!= NULL
)
1523 gfc_free_st_label (gfc_statement_label
);
1524 gfc_statement_label
= NULL
;
1526 gfc_current_locus
= old_locus
;
1530 check_statement_label (st
);
1536 /****************************** Parser ***********************************/
1538 /* The parser subroutines are of type 'try' that fail if the file ends
1541 /* Macros that expand to case-labels for various classes of
1542 statements. Start with executable statements that directly do
1545 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1546 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1547 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1548 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1549 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1550 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1551 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1552 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1553 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1554 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
1555 case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
1556 case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: \
1557 case ST_ERROR_STOP: case ST_SYNC_ALL: \
1558 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1559 case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
1560 case ST_END_TEAM: case ST_SYNC_TEAM: \
1561 case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
1562 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1563 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1565 /* Statements that mark other executable statements. */
1567 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1568 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1569 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1570 case ST_SELECT_RANK: case ST_OMP_PARALLEL: \
1571 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1572 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
1573 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1574 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1575 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1576 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1577 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1578 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1579 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1580 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1581 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1582 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1583 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1584 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1585 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1586 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1587 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \
1588 case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \
1589 case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
1591 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1592 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
1593 case ST_OACC_KERNELS_LOOP: case ST_OACC_SERIAL_LOOP: case ST_OACC_SERIAL: \
1596 /* Declaration statements */
1598 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1599 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1600 case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE: case ST_OACC_ROUTINE: \
1601 case ST_OACC_DECLARE
1603 /* OpenMP declaration statements. */
1605 #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
1606 case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION
1608 /* Block end statements. Errors associated with interchanging these
1609 are detected in gfc_match_end(). */
1611 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1612 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1613 case ST_END_BLOCK: case ST_END_ASSOCIATE
1616 /* Push a new state onto the stack. */
1619 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1621 p
->state
= new_state
;
1622 p
->previous
= gfc_state_stack
;
1624 p
->head
= p
->tail
= NULL
;
1625 p
->do_variable
= NULL
;
1626 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1627 p
->ext
.oacc_declare_clauses
= NULL
;
1629 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1630 construct statement was accepted right before pushing the state. Thus,
1631 the construct's gfc_code is available as tail of the parent state. */
1632 gcc_assert (gfc_state_stack
);
1633 p
->construct
= gfc_state_stack
->tail
;
1635 gfc_state_stack
= p
;
1639 /* Pop the current state. */
1643 gfc_state_stack
= gfc_state_stack
->previous
;
1647 /* Try to find the given state in the state stack. */
1650 gfc_find_state (gfc_compile_state state
)
1654 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1655 if (p
->state
== state
)
1658 return (p
== NULL
) ? false : true;
1662 /* Starts a new level in the statement list. */
1665 new_level (gfc_code
*q
)
1669 p
= q
->block
= gfc_get_code (EXEC_NOP
);
1671 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1677 /* Add the current new_st code structure and adds it to the current
1678 program unit. As a side-effect, it zeroes the new_st. */
1681 add_statement (void)
1685 p
= XCNEW (gfc_code
);
1688 p
->loc
= gfc_current_locus
;
1690 if (gfc_state_stack
->head
== NULL
)
1691 gfc_state_stack
->head
= p
;
1693 gfc_state_stack
->tail
->next
= p
;
1695 while (p
->next
!= NULL
)
1698 gfc_state_stack
->tail
= p
;
1700 gfc_clear_new_st ();
1706 /* Frees everything associated with the current statement. */
1709 undo_new_statement (void)
1711 gfc_free_statements (new_st
.block
);
1712 gfc_free_statements (new_st
.next
);
1713 gfc_free_statement (&new_st
);
1714 gfc_clear_new_st ();
1718 /* If the current statement has a statement label, make sure that it
1719 is allowed to, or should have one. */
1722 check_statement_label (gfc_statement st
)
1726 if (gfc_statement_label
== NULL
)
1728 if (st
== ST_FORMAT
)
1729 gfc_error ("FORMAT statement at %L does not have a statement label",
1736 case ST_END_PROGRAM
:
1737 case ST_END_FUNCTION
:
1738 case ST_END_SUBROUTINE
:
1742 case ST_END_CRITICAL
:
1744 case ST_END_ASSOCIATE
:
1747 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
1748 type
= ST_LABEL_DO_TARGET
;
1750 type
= ST_LABEL_TARGET
;
1754 type
= ST_LABEL_FORMAT
;
1757 /* Statement labels are not restricted from appearing on a
1758 particular line. However, there are plenty of situations
1759 where the resulting label can't be referenced. */
1762 type
= ST_LABEL_BAD_TARGET
;
1766 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1768 new_st
.here
= gfc_statement_label
;
1772 /* Figures out what the enclosing program unit is. This will be a
1773 function, subroutine, program, block data or module. */
1776 gfc_enclosing_unit (gfc_compile_state
* result
)
1780 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1781 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1782 || p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
1783 || p
->state
== COMP_BLOCK_DATA
|| p
->state
== COMP_PROGRAM
)
1792 *result
= COMP_PROGRAM
;
1797 /* Translate a statement enum to a string. */
1800 gfc_ascii_statement (gfc_statement st
)
1806 case ST_ARITHMETIC_IF
:
1807 p
= _("arithmetic IF");
1816 p
= _("attribute declaration");
1852 p
= _("data declaration");
1866 case ST_STRUCTURE_DECL
:
1869 case ST_DERIVED_DECL
:
1870 p
= _("derived type declaration");
1893 case ST_CHANGE_TEAM
:
1905 case ST_END_ASSOCIATE
:
1906 p
= "END ASSOCIATE";
1911 case ST_END_BLOCK_DATA
:
1912 p
= "END BLOCK DATA";
1914 case ST_END_CRITICAL
:
1926 case ST_END_FUNCTION
:
1932 case ST_END_INTERFACE
:
1933 p
= "END INTERFACE";
1938 case ST_END_SUBMODULE
:
1939 p
= "END SUBMODULE";
1941 case ST_END_PROGRAM
:
1947 case ST_END_SUBROUTINE
:
1948 p
= "END SUBROUTINE";
1953 case ST_END_STRUCTURE
:
1954 p
= "END STRUCTURE";
1968 case ST_EQUIVALENCE
:
1980 case ST_FORALL_BLOCK
: /* Fall through */
2002 case ST_IMPLICIT_NONE
:
2003 p
= "IMPLICIT NONE";
2005 case ST_IMPLIED_ENDDO
:
2006 p
= _("implied END DO");
2038 case ST_MODULE_PROC
:
2039 p
= "MODULE PROCEDURE";
2071 case ST_SYNC_IMAGES
:
2074 case ST_SYNC_MEMORY
:
2089 case ST_WHERE_BLOCK
: /* Fall through */
2100 p
= _("assignment");
2102 case ST_POINTER_ASSIGNMENT
:
2103 p
= _("pointer assignment");
2105 case ST_SELECT_CASE
:
2108 case ST_SELECT_TYPE
:
2111 case ST_SELECT_RANK
:
2129 case ST_STATEMENT_FUNCTION
:
2130 p
= "STATEMENT FUNCTION";
2132 case ST_LABEL_ASSIGNMENT
:
2133 p
= "LABEL ASSIGNMENT";
2136 p
= "ENUM DEFINITION";
2139 p
= "ENUMERATOR DEFINITION";
2144 case ST_OACC_PARALLEL_LOOP
:
2145 p
= "!$ACC PARALLEL LOOP";
2147 case ST_OACC_END_PARALLEL_LOOP
:
2148 p
= "!$ACC END PARALLEL LOOP";
2150 case ST_OACC_PARALLEL
:
2151 p
= "!$ACC PARALLEL";
2153 case ST_OACC_END_PARALLEL
:
2154 p
= "!$ACC END PARALLEL";
2156 case ST_OACC_KERNELS
:
2157 p
= "!$ACC KERNELS";
2159 case ST_OACC_END_KERNELS
:
2160 p
= "!$ACC END KERNELS";
2162 case ST_OACC_KERNELS_LOOP
:
2163 p
= "!$ACC KERNELS LOOP";
2165 case ST_OACC_END_KERNELS_LOOP
:
2166 p
= "!$ACC END KERNELS LOOP";
2168 case ST_OACC_SERIAL_LOOP
:
2169 p
= "!$ACC SERIAL LOOP";
2171 case ST_OACC_END_SERIAL_LOOP
:
2172 p
= "!$ACC END SERIAL LOOP";
2174 case ST_OACC_SERIAL
:
2177 case ST_OACC_END_SERIAL
:
2178 p
= "!$ACC END SERIAL";
2183 case ST_OACC_END_DATA
:
2184 p
= "!$ACC END DATA";
2186 case ST_OACC_HOST_DATA
:
2187 p
= "!$ACC HOST_DATA";
2189 case ST_OACC_END_HOST_DATA
:
2190 p
= "!$ACC END HOST_DATA";
2195 case ST_OACC_END_LOOP
:
2196 p
= "!$ACC END LOOP";
2198 case ST_OACC_DECLARE
:
2199 p
= "!$ACC DECLARE";
2201 case ST_OACC_UPDATE
:
2210 case ST_OACC_ENTER_DATA
:
2211 p
= "!$ACC ENTER DATA";
2213 case ST_OACC_EXIT_DATA
:
2214 p
= "!$ACC EXIT DATA";
2216 case ST_OACC_ROUTINE
:
2217 p
= "!$ACC ROUTINE";
2219 case ST_OACC_ATOMIC
:
2222 case ST_OACC_END_ATOMIC
:
2223 p
= "!$ACC END ATOMIC";
2228 case ST_OMP_BARRIER
:
2229 p
= "!$OMP BARRIER";
2234 case ST_OMP_CANCELLATION_POINT
:
2235 p
= "!$OMP CANCELLATION POINT";
2237 case ST_OMP_CRITICAL
:
2238 p
= "!$OMP CRITICAL";
2240 case ST_OMP_DECLARE_REDUCTION
:
2241 p
= "!$OMP DECLARE REDUCTION";
2243 case ST_OMP_DECLARE_SIMD
:
2244 p
= "!$OMP DECLARE SIMD";
2246 case ST_OMP_DECLARE_TARGET
:
2247 p
= "!$OMP DECLARE TARGET";
2249 case ST_OMP_DISTRIBUTE
:
2250 p
= "!$OMP DISTRIBUTE";
2252 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
2253 p
= "!$OMP DISTRIBUTE PARALLEL DO";
2255 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2256 p
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
2258 case ST_OMP_DISTRIBUTE_SIMD
:
2259 p
= "!$OMP DISTRIBUTE SIMD";
2264 case ST_OMP_DO_SIMD
:
2265 p
= "!$OMP DO SIMD";
2267 case ST_OMP_END_ATOMIC
:
2268 p
= "!$OMP END ATOMIC";
2270 case ST_OMP_END_CRITICAL
:
2271 p
= "!$OMP END CRITICAL";
2273 case ST_OMP_END_DISTRIBUTE
:
2274 p
= "!$OMP END DISTRIBUTE";
2276 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO
:
2277 p
= "!$OMP END DISTRIBUTE PARALLEL DO";
2279 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
:
2280 p
= "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
2282 case ST_OMP_END_DISTRIBUTE_SIMD
:
2283 p
= "!$OMP END DISTRIBUTE SIMD";
2288 case ST_OMP_END_DO_SIMD
:
2289 p
= "!$OMP END DO SIMD";
2291 case ST_OMP_END_SIMD
:
2292 p
= "!$OMP END SIMD";
2294 case ST_OMP_END_MASTER
:
2295 p
= "!$OMP END MASTER";
2297 case ST_OMP_END_ORDERED
:
2298 p
= "!$OMP END ORDERED";
2300 case ST_OMP_END_PARALLEL
:
2301 p
= "!$OMP END PARALLEL";
2303 case ST_OMP_END_PARALLEL_DO
:
2304 p
= "!$OMP END PARALLEL DO";
2306 case ST_OMP_END_PARALLEL_DO_SIMD
:
2307 p
= "!$OMP END PARALLEL DO SIMD";
2309 case ST_OMP_END_PARALLEL_SECTIONS
:
2310 p
= "!$OMP END PARALLEL SECTIONS";
2312 case ST_OMP_END_PARALLEL_WORKSHARE
:
2313 p
= "!$OMP END PARALLEL WORKSHARE";
2315 case ST_OMP_END_SECTIONS
:
2316 p
= "!$OMP END SECTIONS";
2318 case ST_OMP_END_SINGLE
:
2319 p
= "!$OMP END SINGLE";
2321 case ST_OMP_END_TASK
:
2322 p
= "!$OMP END TASK";
2324 case ST_OMP_END_TARGET
:
2325 p
= "!$OMP END TARGET";
2327 case ST_OMP_END_TARGET_DATA
:
2328 p
= "!$OMP END TARGET DATA";
2330 case ST_OMP_END_TARGET_PARALLEL
:
2331 p
= "!$OMP END TARGET PARALLEL";
2333 case ST_OMP_END_TARGET_PARALLEL_DO
:
2334 p
= "!$OMP END TARGET PARALLEL DO";
2336 case ST_OMP_END_TARGET_PARALLEL_DO_SIMD
:
2337 p
= "!$OMP END TARGET PARALLEL DO SIMD";
2339 case ST_OMP_END_TARGET_SIMD
:
2340 p
= "!$OMP END TARGET SIMD";
2342 case ST_OMP_END_TARGET_TEAMS
:
2343 p
= "!$OMP END TARGET TEAMS";
2345 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
:
2346 p
= "!$OMP END TARGET TEAMS DISTRIBUTE";
2348 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2349 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2351 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2352 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2354 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2355 p
= "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2357 case ST_OMP_END_TASKGROUP
:
2358 p
= "!$OMP END TASKGROUP";
2360 case ST_OMP_END_TASKLOOP
:
2361 p
= "!$OMP END TASKLOOP";
2363 case ST_OMP_END_TASKLOOP_SIMD
:
2364 p
= "!$OMP END TASKLOOP SIMD";
2366 case ST_OMP_END_TEAMS
:
2367 p
= "!$OMP END TEAMS";
2369 case ST_OMP_END_TEAMS_DISTRIBUTE
:
2370 p
= "!$OMP END TEAMS DISTRIBUTE";
2372 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2373 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2375 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2376 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2378 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
:
2379 p
= "!$OMP END TEAMS DISTRIBUTE SIMD";
2381 case ST_OMP_END_WORKSHARE
:
2382 p
= "!$OMP END WORKSHARE";
2390 case ST_OMP_ORDERED
:
2391 case ST_OMP_ORDERED_DEPEND
:
2392 p
= "!$OMP ORDERED";
2394 case ST_OMP_PARALLEL
:
2395 p
= "!$OMP PARALLEL";
2397 case ST_OMP_PARALLEL_DO
:
2398 p
= "!$OMP PARALLEL DO";
2400 case ST_OMP_PARALLEL_DO_SIMD
:
2401 p
= "!$OMP PARALLEL DO SIMD";
2403 case ST_OMP_PARALLEL_SECTIONS
:
2404 p
= "!$OMP PARALLEL SECTIONS";
2406 case ST_OMP_PARALLEL_WORKSHARE
:
2407 p
= "!$OMP PARALLEL WORKSHARE";
2409 case ST_OMP_SECTIONS
:
2410 p
= "!$OMP SECTIONS";
2412 case ST_OMP_SECTION
:
2413 p
= "!$OMP SECTION";
2424 case ST_OMP_TARGET_DATA
:
2425 p
= "!$OMP TARGET DATA";
2427 case ST_OMP_TARGET_ENTER_DATA
:
2428 p
= "!$OMP TARGET ENTER DATA";
2430 case ST_OMP_TARGET_EXIT_DATA
:
2431 p
= "!$OMP TARGET EXIT DATA";
2433 case ST_OMP_TARGET_PARALLEL
:
2434 p
= "!$OMP TARGET PARALLEL";
2436 case ST_OMP_TARGET_PARALLEL_DO
:
2437 p
= "!$OMP TARGET PARALLEL DO";
2439 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
2440 p
= "!$OMP TARGET PARALLEL DO SIMD";
2442 case ST_OMP_TARGET_SIMD
:
2443 p
= "!$OMP TARGET SIMD";
2445 case ST_OMP_TARGET_TEAMS
:
2446 p
= "!$OMP TARGET TEAMS";
2448 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
2449 p
= "!$OMP TARGET TEAMS DISTRIBUTE";
2451 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2452 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2454 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2455 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2457 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2458 p
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2460 case ST_OMP_TARGET_UPDATE
:
2461 p
= "!$OMP TARGET UPDATE";
2466 case ST_OMP_TASKGROUP
:
2467 p
= "!$OMP TASKGROUP";
2469 case ST_OMP_TASKLOOP
:
2470 p
= "!$OMP TASKLOOP";
2472 case ST_OMP_TASKLOOP_SIMD
:
2473 p
= "!$OMP TASKLOOP SIMD";
2475 case ST_OMP_TASKWAIT
:
2476 p
= "!$OMP TASKWAIT";
2478 case ST_OMP_TASKYIELD
:
2479 p
= "!$OMP TASKYIELD";
2484 case ST_OMP_TEAMS_DISTRIBUTE
:
2485 p
= "!$OMP TEAMS DISTRIBUTE";
2487 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2488 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2490 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2491 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2493 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
2494 p
= "!$OMP TEAMS DISTRIBUTE SIMD";
2496 case ST_OMP_THREADPRIVATE
:
2497 p
= "!$OMP THREADPRIVATE";
2499 case ST_OMP_WORKSHARE
:
2500 p
= "!$OMP WORKSHARE";
2503 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2510 /* Create a symbol for the main program and assign it to ns->proc_name. */
2513 main_program_symbol (gfc_namespace
*ns
, const char *name
)
2515 gfc_symbol
*main_program
;
2516 symbol_attribute attr
;
2518 gfc_get_symbol (name
, ns
, &main_program
);
2519 gfc_clear_attr (&attr
);
2520 attr
.flavor
= FL_PROGRAM
;
2521 attr
.proc
= PROC_UNKNOWN
;
2522 attr
.subroutine
= 1;
2523 attr
.access
= ACCESS_PUBLIC
;
2524 attr
.is_main_program
= 1;
2525 main_program
->attr
= attr
;
2526 main_program
->declared_at
= gfc_current_locus
;
2527 ns
->proc_name
= main_program
;
2528 gfc_commit_symbols ();
2532 /* Do whatever is necessary to accept the last statement. */
2535 accept_statement (gfc_statement st
)
2539 case ST_IMPLICIT_NONE
:
2547 gfc_current_ns
->proc_name
= gfc_new_block
;
2550 /* If the statement is the end of a block, lay down a special code
2551 that allows a branch to the end of the block from within the
2552 construct. IF and SELECT are treated differently from DO
2553 (where EXEC_NOP is added inside the loop) for two
2555 1. END DO has a meaning in the sense that after a GOTO to
2556 it, the loop counter must be increased.
2557 2. IF blocks and SELECT blocks can consist of multiple
2558 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
2559 Putting the label before the END IF would make the jump
2560 from, say, the ELSE IF block to the END IF illegal. */
2564 case ST_END_CRITICAL
:
2565 if (gfc_statement_label
!= NULL
)
2567 new_st
.op
= EXEC_END_NESTED_BLOCK
;
2572 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
2573 one parallel block. Thus, we add the special code to the nested block
2574 itself, instead of the parent one. */
2576 case ST_END_ASSOCIATE
:
2577 if (gfc_statement_label
!= NULL
)
2579 new_st
.op
= EXEC_END_BLOCK
;
2584 /* The end-of-program unit statements do not get the special
2585 marker and require a statement of some sort if they are a
2588 case ST_END_PROGRAM
:
2589 case ST_END_FUNCTION
:
2590 case ST_END_SUBROUTINE
:
2591 if (gfc_statement_label
!= NULL
)
2593 new_st
.op
= EXEC_RETURN
;
2598 new_st
.op
= EXEC_END_PROCEDURE
;
2614 gfc_commit_symbols ();
2615 gfc_warning_check ();
2616 gfc_clear_new_st ();
2620 /* Undo anything tentative that has been built for the current statement,
2621 except if a gfc_charlen structure has been added to current namespace's
2622 list of gfc_charlen structure. */
2625 reject_statement (void)
2627 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
2628 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
2630 gfc_reject_data (gfc_current_ns
);
2632 gfc_new_block
= NULL
;
2633 gfc_undo_symbols ();
2634 gfc_clear_warning ();
2635 undo_new_statement ();
2639 /* Generic complaint about an out of order statement. We also do
2640 whatever is necessary to clean up. */
2643 unexpected_statement (gfc_statement st
)
2645 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
2647 reject_statement ();
2651 /* Given the next statement seen by the matcher, make sure that it is
2652 in proper order with the last. This subroutine is initialized by
2653 calling it with an argument of ST_NONE. If there is a problem, we
2654 issue an error and return false. Otherwise we return true.
2656 Individual parsers need to verify that the statements seen are
2657 valid before calling here, i.e., ENTRY statements are not allowed in
2658 INTERFACE blocks. The following diagram is taken from the standard:
2660 +---------------------------------------+
2661 | program subroutine function module |
2662 +---------------------------------------+
2664 +---------------------------------------+
2666 +---------------------------------------+
2668 | +-----------+------------------+
2669 | | parameter | implicit |
2670 | +-----------+------------------+
2671 | format | | derived type |
2672 | entry | parameter | interface |
2673 | | data | specification |
2674 | | | statement func |
2675 | +-----------+------------------+
2676 | | data | executable |
2677 +--------+-----------+------------------+
2679 +---------------------------------------+
2680 | internal module/subprogram |
2681 +---------------------------------------+
2683 +---------------------------------------+
2692 ORDER_IMPLICIT_NONE
,
2700 enum state_order state
;
2701 gfc_statement last_statement
;
2707 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
2713 p
->state
= ORDER_START
;
2717 if (p
->state
> ORDER_USE
)
2719 p
->state
= ORDER_USE
;
2723 if (p
->state
> ORDER_IMPORT
)
2725 p
->state
= ORDER_IMPORT
;
2728 case ST_IMPLICIT_NONE
:
2729 if (p
->state
> ORDER_IMPLICIT
)
2732 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2733 statement disqualifies a USE but not an IMPLICIT NONE.
2734 Duplicate IMPLICIT NONEs are caught when the implicit types
2737 p
->state
= ORDER_IMPLICIT_NONE
;
2741 if (p
->state
> ORDER_IMPLICIT
)
2743 p
->state
= ORDER_IMPLICIT
;
2748 if (p
->state
< ORDER_IMPLICIT_NONE
)
2749 p
->state
= ORDER_IMPLICIT_NONE
;
2753 if (p
->state
>= ORDER_EXEC
)
2755 if (p
->state
< ORDER_IMPLICIT
)
2756 p
->state
= ORDER_IMPLICIT
;
2760 if (p
->state
< ORDER_SPEC
)
2761 p
->state
= ORDER_SPEC
;
2766 case ST_STRUCTURE_DECL
:
2767 case ST_DERIVED_DECL
:
2769 if (p
->state
>= ORDER_EXEC
)
2771 if (p
->state
< ORDER_SPEC
)
2772 p
->state
= ORDER_SPEC
;
2776 /* The OpenMP directives have to be somewhere in the specification
2777 part, but there are no further requirements on their ordering.
2778 Thus don't adjust p->state, just ignore them. */
2779 if (p
->state
>= ORDER_EXEC
)
2785 if (p
->state
< ORDER_EXEC
)
2786 p
->state
= ORDER_EXEC
;
2793 /* All is well, record the statement in case we need it next time. */
2794 p
->where
= gfc_current_locus
;
2795 p
->last_statement
= st
;
2800 gfc_error ("%s statement at %C cannot follow %s statement at %L",
2801 gfc_ascii_statement (st
),
2802 gfc_ascii_statement (p
->last_statement
), &p
->where
);
2808 /* Handle an unexpected end of file. This is a show-stopper... */
2810 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
2813 unexpected_eof (void)
2817 gfc_error ("Unexpected end of file in %qs", gfc_source_file
);
2819 /* Memory cleanup. Move to "second to last". */
2820 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
2823 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
2826 longjmp (eof_buf
, 1);
2828 /* Avoids build error on systems where longjmp is not declared noreturn. */
2833 /* Parse the CONTAINS section of a derived type definition. */
2835 gfc_access gfc_typebound_default_access
;
2838 parse_derived_contains (void)
2841 bool seen_private
= false;
2842 bool seen_comps
= false;
2843 bool error_flag
= false;
2846 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2847 gcc_assert (gfc_current_block ());
2849 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
2851 if (gfc_current_block ()->attr
.sequence
)
2852 gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
2853 " section at %C", gfc_current_block ()->name
);
2854 if (gfc_current_block ()->attr
.is_bind_c
)
2855 gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
2856 " section at %C", gfc_current_block ()->name
);
2858 accept_statement (ST_CONTAINS
);
2859 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
2861 gfc_typebound_default_access
= ACCESS_PUBLIC
;
2867 st
= next_statement ();
2875 gfc_error ("Components in TYPE at %C must precede CONTAINS");
2879 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
2882 accept_statement (ST_PROCEDURE
);
2887 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
2890 accept_statement (ST_GENERIC
);
2895 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
2899 accept_statement (ST_FINAL
);
2907 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
2908 "at %C with empty CONTAINS section")))
2911 /* ST_END_TYPE is accepted by parse_derived after return. */
2915 if (!gfc_find_state (COMP_MODULE
))
2917 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2924 gfc_error ("PRIVATE statement at %C must precede procedure"
2931 gfc_error ("Duplicate PRIVATE statement at %C");
2935 accept_statement (ST_PRIVATE
);
2936 gfc_typebound_default_access
= ACCESS_PRIVATE
;
2937 seen_private
= true;
2941 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2945 gfc_error ("Already inside a CONTAINS block at %C");
2949 unexpected_statement (st
);
2957 reject_statement ();
2961 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2967 /* Set attributes for the parent symbol based on the attributes of a component
2968 and raise errors if conflicting attributes are found for the component. */
2971 check_component (gfc_symbol
*sym
, gfc_component
*c
, gfc_component
**lockp
,
2972 gfc_component
**eventp
)
2974 bool coarray
, lock_type
, event_type
, allocatable
, pointer
;
2975 coarray
= lock_type
= event_type
= allocatable
= pointer
= false;
2976 gfc_component
*lock_comp
= NULL
, *event_comp
= NULL
;
2978 if (lockp
) lock_comp
= *lockp
;
2979 if (eventp
) event_comp
= *eventp
;
2981 /* Look for allocatable components. */
2982 if (c
->attr
.allocatable
2983 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2984 && CLASS_DATA (c
)->attr
.allocatable
)
2985 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
2986 && c
->ts
.u
.derived
->attr
.alloc_comp
))
2989 sym
->attr
.alloc_comp
= 1;
2992 /* Look for pointer components. */
2994 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
2995 && CLASS_DATA (c
)->attr
.class_pointer
)
2996 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
2999 sym
->attr
.pointer_comp
= 1;
3002 /* Look for procedure pointer components. */
3003 if (c
->attr
.proc_pointer
3004 || (c
->ts
.type
== BT_DERIVED
3005 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
3006 sym
->attr
.proc_pointer_comp
= 1;
3008 /* Looking for coarray components. */
3009 if (c
->attr
.codimension
3010 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3011 && CLASS_DATA (c
)->attr
.codimension
))
3014 sym
->attr
.coarray_comp
= 1;
3017 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
3018 && !c
->attr
.pointer
)
3021 sym
->attr
.coarray_comp
= 1;
3024 /* Looking for lock_type components. */
3025 if ((c
->ts
.type
== BT_DERIVED
3026 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3027 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3028 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3029 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
3030 == INTMOD_ISO_FORTRAN_ENV
3031 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
3032 == ISOFORTRAN_LOCK_TYPE
)
3033 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
3034 && !allocatable
&& !pointer
))
3038 sym
->attr
.lock_comp
= 1;
3041 /* Looking for event_type components. */
3042 if ((c
->ts
.type
== BT_DERIVED
3043 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3044 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
3045 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3046 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
3047 == INTMOD_ISO_FORTRAN_ENV
3048 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
3049 == ISOFORTRAN_EVENT_TYPE
)
3050 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.event_comp
3051 && !allocatable
&& !pointer
))
3055 sym
->attr
.event_comp
= 1;
3058 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
3059 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
3060 unless there are nondirect [allocatable or pointer] components
3061 involved (cf. 1.3.33.1 and 1.3.33.3). */
3063 if (pointer
&& !coarray
&& lock_type
)
3064 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
3065 "codimension or be a subcomponent of a coarray, "
3066 "which is not possible as the component has the "
3067 "pointer attribute", c
->name
, &c
->loc
);
3068 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
3069 && c
->ts
.u
.derived
->attr
.lock_comp
)
3070 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3071 "of type LOCK_TYPE, which must have a codimension or be a "
3072 "subcomponent of a coarray", c
->name
, &c
->loc
);
3074 if (lock_type
&& allocatable
&& !coarray
)
3075 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
3076 "a codimension", c
->name
, &c
->loc
);
3077 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
3078 && c
->ts
.u
.derived
->attr
.lock_comp
)
3079 gfc_error ("Allocatable component %s at %L must have a codimension as "
3080 "it has a noncoarray subcomponent of type LOCK_TYPE",
3083 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
3084 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3085 "subcomponent of type LOCK_TYPE must have a codimension or "
3086 "be a subcomponent of a coarray. (Variables of type %s may "
3087 "not have a codimension as already a coarray "
3088 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
3090 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
3091 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3092 "subcomponent of type LOCK_TYPE must have a codimension or "
3093 "be a subcomponent of a coarray. (Variables of type %s may "
3094 "not have a codimension as %s at %L has a codimension or a "
3095 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
3096 sym
->name
, c
->name
, &c
->loc
);
3098 /* Similarly for EVENT TYPE. */
3100 if (pointer
&& !coarray
&& event_type
)
3101 gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
3102 "codimension or be a subcomponent of a coarray, "
3103 "which is not possible as the component has the "
3104 "pointer attribute", c
->name
, &c
->loc
);
3105 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
3106 && c
->ts
.u
.derived
->attr
.event_comp
)
3107 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3108 "of type EVENT_TYPE, which must have a codimension or be a "
3109 "subcomponent of a coarray", c
->name
, &c
->loc
);
3111 if (event_type
&& allocatable
&& !coarray
)
3112 gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
3113 "a codimension", c
->name
, &c
->loc
);
3114 else if (event_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
3115 && c
->ts
.u
.derived
->attr
.event_comp
)
3116 gfc_error ("Allocatable component %s at %L must have a codimension as "
3117 "it has a noncoarray subcomponent of type EVENT_TYPE",
3120 if (sym
->attr
.coarray_comp
&& !coarray
&& event_type
)
3121 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3122 "subcomponent of type EVENT_TYPE must have a codimension or "
3123 "be a subcomponent of a coarray. (Variables of type %s may "
3124 "not have a codimension as already a coarray "
3125 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
3127 if (sym
->attr
.event_comp
&& coarray
&& !event_type
)
3128 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3129 "subcomponent of type EVENT_TYPE must have a codimension or "
3130 "be a subcomponent of a coarray. (Variables of type %s may "
3131 "not have a codimension as %s at %L has a codimension or a "
3132 "coarray subcomponent)", event_comp
->name
, &event_comp
->loc
,
3133 sym
->name
, c
->name
, &c
->loc
);
3135 /* Look for private components. */
3136 if (sym
->component_access
== ACCESS_PRIVATE
3137 || c
->attr
.access
== ACCESS_PRIVATE
3138 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
3139 sym
->attr
.private_comp
= 1;
3141 if (lockp
) *lockp
= lock_comp
;
3142 if (eventp
) *eventp
= event_comp
;
3146 static void parse_struct_map (gfc_statement
);
3148 /* Parse a union component definition within a structure definition. */
3156 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3159 accept_statement(ST_UNION
);
3160 push_state (&s
, COMP_UNION
, gfc_new_block
);
3167 st
= next_statement ();
3168 /* Only MAP declarations valid within a union. */
3175 accept_statement (ST_MAP
);
3176 parse_struct_map (ST_MAP
);
3177 /* Add a component to the union for each map. */
3178 if (!gfc_add_component (un
, gfc_new_block
->name
, &c
))
3180 gfc_internal_error ("failed to create map component '%s'",
3181 gfc_new_block
->name
);
3182 reject_statement ();
3185 c
->ts
.type
= BT_DERIVED
;
3186 c
->ts
.u
.derived
= gfc_new_block
;
3187 /* Normally components get their initialization expressions when they
3188 are created in decl.c (build_struct) so we can look through the
3189 flat component list for initializers during resolution. Unions and
3190 maps create components along with their type definitions so we
3191 have to generate initializers here. */
3192 c
->initializer
= gfc_default_initializer (&c
->ts
);
3197 accept_statement (ST_END_UNION
);
3201 unexpected_statement (st
);
3206 for (c
= un
->components
; c
; c
= c
->next
)
3207 check_component (un
, c
, &lock_comp
, &event_comp
);
3209 /* Add the union as a component in its parent structure. */
3211 if (!gfc_add_component (gfc_current_block (), un
->name
, &c
))
3213 gfc_internal_error ("failed to create union component '%s'", un
->name
);
3214 reject_statement ();
3217 c
->ts
.type
= BT_UNION
;
3218 c
->ts
.u
.derived
= un
;
3219 c
->initializer
= gfc_default_initializer (&c
->ts
);
3221 un
->attr
.zero_comp
= un
->components
== NULL
;
3225 /* Parse a STRUCTURE or MAP. */
3228 parse_struct_map (gfc_statement block
)
3234 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3235 gfc_compile_state comp
;
3238 if (block
== ST_STRUCTURE_DECL
)
3240 comp
= COMP_STRUCTURE
;
3241 ends
= ST_END_STRUCTURE
;
3245 gcc_assert (block
== ST_MAP
);
3250 accept_statement(block
);
3251 push_state (&s
, comp
, gfc_new_block
);
3253 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3256 while (compiling_type
)
3258 st
= next_statement ();
3264 /* Nested structure declarations will be captured as ST_DATA_DECL. */
3265 case ST_STRUCTURE_DECL
:
3266 /* Let a more specific error make it to decode_statement(). */
3267 if (gfc_error_check () == 0)
3268 gfc_error ("Syntax error in nested structure declaration at %C");
3269 reject_statement ();
3270 /* Skip the rest of this statement. */
3271 gfc_error_recovery ();
3275 accept_statement (ST_UNION
);
3280 /* The data declaration was a nested/ad-hoc STRUCTURE field. */
3281 accept_statement (ST_DATA_DECL
);
3282 if (gfc_new_block
&& gfc_new_block
!= gfc_current_block ()
3283 && gfc_new_block
->attr
.flavor
== FL_STRUCT
)
3284 parse_struct_map (ST_STRUCTURE_DECL
);
3287 case ST_END_STRUCTURE
:
3291 accept_statement (st
);
3295 unexpected_statement (st
);
3299 unexpected_statement (st
);
3304 /* Validate each component. */
3305 sym
= gfc_current_block ();
3306 for (c
= sym
->components
; c
; c
= c
->next
)
3307 check_component (sym
, c
, &lock_comp
, &event_comp
);
3309 sym
->attr
.zero_comp
= (sym
->components
== NULL
);
3311 /* Allow parse_union to find this structure to add to its list of maps. */
3312 if (block
== ST_MAP
)
3313 gfc_new_block
= gfc_current_block ();
3319 /* Parse a derived type. */
3322 parse_derived (void)
3324 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
3328 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3330 accept_statement (ST_DERIVED_DECL
);
3331 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
3333 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3340 while (compiling_type
)
3342 st
= next_statement ();
3350 accept_statement (st
);
3355 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
3362 if (!seen_component
)
3363 gfc_notify_std (GFC_STD_F2003
, "Derived type "
3364 "definition at %C without components");
3366 accept_statement (ST_END_TYPE
);
3370 if (!gfc_find_state (COMP_MODULE
))
3372 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3379 gfc_error ("PRIVATE statement at %C must precede "
3380 "structure components");
3385 gfc_error ("Duplicate PRIVATE statement at %C");
3387 s
.sym
->component_access
= ACCESS_PRIVATE
;
3389 accept_statement (ST_PRIVATE
);
3396 gfc_error ("SEQUENCE statement at %C must precede "
3397 "structure components");
3401 if (gfc_current_block ()->attr
.sequence
)
3402 gfc_warning (0, "SEQUENCE attribute at %C already specified in "
3407 gfc_error ("Duplicate SEQUENCE statement at %C");
3411 gfc_add_sequence (&gfc_current_block ()->attr
,
3412 gfc_current_block ()->name
, NULL
);
3416 gfc_notify_std (GFC_STD_F2003
,
3417 "CONTAINS block in derived type"
3418 " definition at %C");
3420 accept_statement (ST_CONTAINS
);
3421 parse_derived_contains ();
3425 unexpected_statement (st
);
3430 /* need to verify that all fields of the derived type are
3431 * interoperable with C if the type is declared to be bind(c)
3433 sym
= gfc_current_block ();
3434 for (c
= sym
->components
; c
; c
= c
->next
)
3435 check_component (sym
, c
, &lock_comp
, &event_comp
);
3437 if (!seen_component
)
3438 sym
->attr
.zero_comp
= 1;
3444 /* Parse an ENUM. */
3452 int seen_enumerator
= 0;
3454 push_state (&s
, COMP_ENUM
, gfc_new_block
);
3458 while (compiling_enum
)
3460 st
= next_statement ();
3468 seen_enumerator
= 1;
3469 accept_statement (st
);
3474 if (!seen_enumerator
)
3475 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
3476 accept_statement (st
);
3480 gfc_free_enum_history ();
3481 unexpected_statement (st
);
3489 /* Parse an interface. We must be able to deal with the possibility
3490 of recursive interfaces. The parse_spec() subroutine is mutually
3491 recursive with parse_interface(). */
3493 static gfc_statement
parse_spec (gfc_statement
);
3496 parse_interface (void)
3498 gfc_compile_state new_state
= COMP_NONE
, current_state
;
3499 gfc_symbol
*prog_unit
, *sym
;
3500 gfc_interface_info save
;
3501 gfc_state_data s1
, s2
;
3504 accept_statement (ST_INTERFACE
);
3506 current_interface
.ns
= gfc_current_ns
;
3507 save
= current_interface
;
3509 sym
= (current_interface
.type
== INTERFACE_GENERIC
3510 || current_interface
.type
== INTERFACE_USER_OP
)
3511 ? gfc_new_block
: NULL
;
3513 push_state (&s1
, COMP_INTERFACE
, sym
);
3514 current_state
= COMP_NONE
;
3517 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
3519 st
= next_statement ();
3527 if (st
== ST_SUBROUTINE
)
3528 new_state
= COMP_SUBROUTINE
;
3529 else if (st
== ST_FUNCTION
)
3530 new_state
= COMP_FUNCTION
;
3531 if (gfc_new_block
->attr
.pointer
)
3533 gfc_new_block
->attr
.pointer
= 0;
3534 gfc_new_block
->attr
.proc_pointer
= 1;
3536 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
3537 gfc_new_block
->formal
, NULL
))
3539 reject_statement ();
3540 gfc_free_namespace (gfc_current_ns
);
3543 /* F2008 C1210 forbids the IMPORT statement in module procedure
3544 interface bodies and the flag is set to import symbols. */
3545 if (gfc_new_block
->attr
.module_procedure
)
3546 gfc_current_ns
->has_import_set
= 1;
3550 case ST_MODULE_PROC
: /* The module procedure matcher makes
3551 sure the context is correct. */
3552 accept_statement (st
);
3553 gfc_free_namespace (gfc_current_ns
);
3556 case ST_END_INTERFACE
:
3557 gfc_free_namespace (gfc_current_ns
);
3558 gfc_current_ns
= current_interface
.ns
;
3562 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
3563 gfc_ascii_statement (st
));
3564 reject_statement ();
3565 gfc_free_namespace (gfc_current_ns
);
3570 /* Make sure that the generic name has the right attribute. */
3571 if (current_interface
.type
== INTERFACE_GENERIC
3572 && current_state
== COMP_NONE
)
3574 if (new_state
== COMP_FUNCTION
&& sym
)
3575 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
3576 else if (new_state
== COMP_SUBROUTINE
&& sym
)
3577 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
3579 current_state
= new_state
;
3582 if (current_interface
.type
== INTERFACE_ABSTRACT
)
3584 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
3585 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
3586 gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
3587 "cannot be the same as an intrinsic type",
3588 gfc_new_block
->name
);
3591 push_state (&s2
, new_state
, gfc_new_block
);
3592 accept_statement (st
);
3593 prog_unit
= gfc_new_block
;
3594 prog_unit
->formal_ns
= gfc_current_ns
;
3595 if (prog_unit
== prog_unit
->formal_ns
->proc_name
3596 && prog_unit
->ns
!= prog_unit
->formal_ns
)
3600 /* Read data declaration statements. */
3601 st
= parse_spec (ST_NONE
);
3602 in_specification_block
= true;
3604 /* Since the interface block does not permit an IMPLICIT statement,
3605 the default type for the function or the result must be taken
3606 from the formal namespace. */
3607 if (new_state
== COMP_FUNCTION
)
3609 if (prog_unit
->result
== prog_unit
3610 && prog_unit
->ts
.type
== BT_UNKNOWN
)
3611 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
3612 else if (prog_unit
->result
!= prog_unit
3613 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
3614 gfc_set_default_type (prog_unit
->result
, 1,
3615 prog_unit
->formal_ns
);
3618 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
3620 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
3621 gfc_ascii_statement (st
));
3622 reject_statement ();
3626 /* Add EXTERNAL attribute to function or subroutine. */
3627 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
3628 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
3630 current_interface
= save
;
3631 gfc_add_interface (prog_unit
);
3634 if (current_interface
.ns
3635 && current_interface
.ns
->proc_name
3636 && strcmp (current_interface
.ns
->proc_name
->name
,
3637 prog_unit
->name
) == 0)
3638 gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
3639 "enclosing procedure", prog_unit
->name
,
3640 ¤t_interface
.ns
->proc_name
->declared_at
);
3649 /* Associate function characteristics by going back to the function
3650 declaration and rematching the prefix. */
3653 match_deferred_characteristics (gfc_typespec
* ts
)
3656 match m
= MATCH_ERROR
;
3657 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3659 loc
= gfc_current_locus
;
3661 gfc_current_locus
= gfc_current_block ()->declared_at
;
3664 gfc_buffer_error (true);
3665 m
= gfc_match_prefix (ts
);
3666 gfc_buffer_error (false);
3668 if (ts
->type
== BT_DERIVED
)
3676 /* Only permit one go at the characteristic association. */
3680 /* Set the function locus correctly. If we have not found the
3681 function name, there is an error. */
3683 && gfc_match ("function% %n", name
) == MATCH_YES
3684 && strcmp (name
, gfc_current_block ()->name
) == 0)
3686 gfc_current_block ()->declared_at
= gfc_current_locus
;
3687 gfc_commit_symbols ();
3692 gfc_undo_symbols ();
3695 gfc_current_locus
=loc
;
3700 /* Check specification-expressions in the function result of the currently
3701 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
3702 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
3703 scope are not yet parsed so this has to be delayed up to parse_spec. */
3706 check_function_result_typed (void)
3710 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
3712 if (!gfc_current_ns
->proc_name
->result
) return;
3714 ts
= gfc_current_ns
->proc_name
->result
->ts
;
3716 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
3717 /* TODO: Extend when KIND type parameters are implemented. */
3718 if (ts
.type
== BT_CHARACTER
&& ts
.u
.cl
&& ts
.u
.cl
->length
)
3719 gfc_expr_check_typed (ts
.u
.cl
->length
, gfc_current_ns
, true);
3723 /* Parse a set of specification statements. Returns the statement
3724 that doesn't fit. */
3726 static gfc_statement
3727 parse_spec (gfc_statement st
)
3730 bool function_result_typed
= false;
3731 bool bad_characteristic
= false;
3734 in_specification_block
= true;
3736 verify_st_order (&ss
, ST_NONE
, false);
3738 st
= next_statement ();
3740 /* If we are not inside a function or don't have a result specified so far,
3741 do nothing special about it. */
3742 if (gfc_current_state () != COMP_FUNCTION
)
3743 function_result_typed
= true;
3746 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
3749 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
3750 function_result_typed
= true;
3755 /* If we're inside a BLOCK construct, some statements are disallowed.
3756 Check this here. Attribute declaration statements like INTENT, OPTIONAL
3757 or VALUE are also disallowed, but they don't have a particular ST_*
3758 key so we have to check for them individually in their matcher routine. */
3759 if (gfc_current_state () == COMP_BLOCK
)
3763 case ST_IMPLICIT_NONE
:
3766 case ST_EQUIVALENCE
:
3767 case ST_STATEMENT_FUNCTION
:
3768 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
3769 gfc_ascii_statement (st
));
3770 reject_statement ();
3776 else if (gfc_current_state () == COMP_BLOCK_DATA
)
3777 /* Fortran 2008, C1116. */
3784 case ST_DERIVED_DECL
:
3785 case ST_END_BLOCK_DATA
:
3786 case ST_EQUIVALENCE
:
3788 case ST_IMPLICIT_NONE
:
3789 case ST_OMP_THREADPRIVATE
:
3791 case ST_STRUCTURE_DECL
:
3800 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
3801 gfc_ascii_statement (st
));
3802 reject_statement ();
3806 /* If we find a statement that cannot be followed by an IMPLICIT statement
3807 (and thus we can expect to see none any further), type the function result
3808 if it has not yet been typed. Be careful not to give the END statement
3809 to verify_st_order! */
3810 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
3812 bool verify_now
= false;
3814 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
3819 verify_st_order (&dummyss
, ST_NONE
, false);
3820 verify_st_order (&dummyss
, st
, false);
3822 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
3828 check_function_result_typed ();
3829 function_result_typed
= true;
3838 case ST_IMPLICIT_NONE
:
3840 if (!function_result_typed
)
3842 check_function_result_typed ();
3843 function_result_typed
= true;
3849 case ST_DATA
: /* Not allowed in interfaces */
3850 if (gfc_current_state () == COMP_INTERFACE
)
3860 case ST_STRUCTURE_DECL
:
3861 case ST_DERIVED_DECL
:
3865 if (!verify_st_order (&ss
, st
, false))
3867 reject_statement ();
3868 st
= next_statement ();
3878 case ST_STRUCTURE_DECL
:
3879 parse_struct_map (ST_STRUCTURE_DECL
);
3882 case ST_DERIVED_DECL
:
3888 if (gfc_current_state () != COMP_MODULE
)
3890 gfc_error ("%s statement must appear in a MODULE",
3891 gfc_ascii_statement (st
));
3892 reject_statement ();
3896 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
3898 gfc_error ("%s statement at %C follows another accessibility "
3899 "specification", gfc_ascii_statement (st
));
3900 reject_statement ();
3904 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
3905 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3909 case ST_STATEMENT_FUNCTION
:
3910 if (gfc_current_state () == COMP_MODULE
3911 || gfc_current_state () == COMP_SUBMODULE
)
3913 unexpected_statement (st
);
3921 accept_statement (st
);
3922 st
= next_statement ();
3926 accept_statement (st
);
3928 st
= next_statement ();
3931 case ST_GET_FCN_CHARACTERISTICS
:
3932 /* This statement triggers the association of a function's result
3934 ts
= &gfc_current_block ()->result
->ts
;
3935 if (match_deferred_characteristics (ts
) != MATCH_YES
)
3936 bad_characteristic
= true;
3938 st
= next_statement ();
3945 /* If match_deferred_characteristics failed, then there is an error. */
3946 if (bad_characteristic
)
3948 ts
= &gfc_current_block ()->result
->ts
;
3949 if (ts
->type
!= BT_DERIVED
)
3950 gfc_error ("Bad kind expression for function %qs at %L",
3951 gfc_current_block ()->name
,
3952 &gfc_current_block ()->declared_at
);
3954 gfc_error ("The type for function %qs at %L is not accessible",
3955 gfc_current_block ()->name
,
3956 &gfc_current_block ()->declared_at
);
3958 gfc_current_block ()->ts
.kind
= 0;
3959 /* Keep the derived type; if it's bad, it will be discovered later. */
3960 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
3961 ts
->type
= BT_UNKNOWN
;
3964 in_specification_block
= false;
3970 /* Parse a WHERE block, (not a simple WHERE statement). */
3973 parse_where_block (void)
3975 int seen_empty_else
;
3980 accept_statement (ST_WHERE_BLOCK
);
3981 top
= gfc_state_stack
->tail
;
3983 push_state (&s
, COMP_WHERE
, gfc_new_block
);
3985 d
= add_statement ();
3986 d
->expr1
= top
->expr1
;
3992 seen_empty_else
= 0;
3996 st
= next_statement ();
4002 case ST_WHERE_BLOCK
:
4003 parse_where_block ();
4008 accept_statement (st
);
4012 if (seen_empty_else
)
4014 gfc_error ("ELSEWHERE statement at %C follows previous "
4015 "unmasked ELSEWHERE");
4016 reject_statement ();
4020 if (new_st
.expr1
== NULL
)
4021 seen_empty_else
= 1;
4023 d
= new_level (gfc_state_stack
->head
);
4025 d
->expr1
= new_st
.expr1
;
4027 accept_statement (st
);
4032 accept_statement (st
);
4036 gfc_error ("Unexpected %s statement in WHERE block at %C",
4037 gfc_ascii_statement (st
));
4038 reject_statement ();
4042 while (st
!= ST_END_WHERE
);
4048 /* Parse a FORALL block (not a simple FORALL statement). */
4051 parse_forall_block (void)
4057 accept_statement (ST_FORALL_BLOCK
);
4058 top
= gfc_state_stack
->tail
;
4060 push_state (&s
, COMP_FORALL
, gfc_new_block
);
4062 d
= add_statement ();
4063 d
->op
= EXEC_FORALL
;
4068 st
= next_statement ();
4073 case ST_POINTER_ASSIGNMENT
:
4076 accept_statement (st
);
4079 case ST_WHERE_BLOCK
:
4080 parse_where_block ();
4083 case ST_FORALL_BLOCK
:
4084 parse_forall_block ();
4088 accept_statement (st
);
4095 gfc_error ("Unexpected %s statement in FORALL block at %C",
4096 gfc_ascii_statement (st
));
4098 reject_statement ();
4102 while (st
!= ST_END_FORALL
);
4108 static gfc_statement
parse_executable (gfc_statement
);
4110 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
4113 parse_if_block (void)
4122 accept_statement (ST_IF_BLOCK
);
4124 top
= gfc_state_stack
->tail
;
4125 push_state (&s
, COMP_IF
, gfc_new_block
);
4127 new_st
.op
= EXEC_IF
;
4128 d
= add_statement ();
4130 d
->expr1
= top
->expr1
;
4136 st
= parse_executable (ST_NONE
);
4146 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
4147 "statement at %L", &else_locus
);
4149 reject_statement ();
4153 d
= new_level (gfc_state_stack
->head
);
4155 d
->expr1
= new_st
.expr1
;
4157 accept_statement (st
);
4164 gfc_error ("Duplicate ELSE statements at %L and %C",
4166 reject_statement ();
4171 else_locus
= gfc_current_locus
;
4173 d
= new_level (gfc_state_stack
->head
);
4176 accept_statement (st
);
4184 unexpected_statement (st
);
4188 while (st
!= ST_ENDIF
);
4191 accept_statement (st
);
4195 /* Parse a SELECT block. */
4198 parse_select_block (void)
4204 accept_statement (ST_SELECT_CASE
);
4206 cp
= gfc_state_stack
->tail
;
4207 push_state (&s
, COMP_SELECT
, gfc_new_block
);
4209 /* Make sure that the next statement is a CASE or END SELECT. */
4212 st
= next_statement ();
4215 if (st
== ST_END_SELECT
)
4217 /* Empty SELECT CASE is OK. */
4218 accept_statement (st
);
4225 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
4228 reject_statement ();
4231 /* At this point, we've got a nonempty select block. */
4232 cp
= new_level (cp
);
4235 accept_statement (st
);
4239 st
= parse_executable (ST_NONE
);
4246 cp
= new_level (gfc_state_stack
->head
);
4248 gfc_clear_new_st ();
4250 accept_statement (st
);
4256 /* Can't have an executable statement because of
4257 parse_executable(). */
4259 unexpected_statement (st
);
4263 while (st
!= ST_END_SELECT
);
4266 accept_statement (st
);
4270 /* Pop the current selector from the SELECT TYPE stack. */
4273 select_type_pop (void)
4275 gfc_select_type_stack
*old
= select_type_stack
;
4276 select_type_stack
= old
->prev
;
4281 /* Parse a SELECT TYPE construct (F03:R821). */
4284 parse_select_type_block (void)
4290 gfc_current_ns
= new_st
.ext
.block
.ns
;
4291 accept_statement (ST_SELECT_TYPE
);
4293 cp
= gfc_state_stack
->tail
;
4294 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
4296 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
4300 st
= next_statement ();
4303 if (st
== ST_END_SELECT
)
4304 /* Empty SELECT CASE is OK. */
4306 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
4309 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
4310 "following SELECT TYPE at %C");
4312 reject_statement ();
4315 /* At this point, we've got a nonempty select block. */
4316 cp
= new_level (cp
);
4319 accept_statement (st
);
4323 st
= parse_executable (ST_NONE
);
4331 cp
= new_level (gfc_state_stack
->head
);
4333 gfc_clear_new_st ();
4335 accept_statement (st
);
4341 /* Can't have an executable statement because of
4342 parse_executable(). */
4344 unexpected_statement (st
);
4348 while (st
!= ST_END_SELECT
);
4352 accept_statement (st
);
4353 gfc_current_ns
= gfc_current_ns
->parent
;
4358 /* Parse a SELECT RANK construct. */
4361 parse_select_rank_block (void)
4367 gfc_current_ns
= new_st
.ext
.block
.ns
;
4368 accept_statement (ST_SELECT_RANK
);
4370 cp
= gfc_state_stack
->tail
;
4371 push_state (&s
, COMP_SELECT_RANK
, gfc_new_block
);
4373 /* Make sure that the next statement is a RANK IS or RANK DEFAULT. */
4376 st
= next_statement ();
4379 if (st
== ST_END_SELECT
)
4380 /* Empty SELECT CASE is OK. */
4385 gfc_error ("Expected RANK or RANK DEFAULT "
4386 "following SELECT RANK at %C");
4388 reject_statement ();
4391 /* At this point, we've got a nonempty select block. */
4392 cp
= new_level (cp
);
4395 accept_statement (st
);
4399 st
= parse_executable (ST_NONE
);
4406 cp
= new_level (gfc_state_stack
->head
);
4408 gfc_clear_new_st ();
4410 accept_statement (st
);
4416 /* Can't have an executable statement because of
4417 parse_executable(). */
4419 unexpected_statement (st
);
4423 while (st
!= ST_END_SELECT
);
4427 accept_statement (st
);
4428 gfc_current_ns
= gfc_current_ns
->parent
;
4433 /* Given a symbol, make sure it is not an iteration variable for a DO
4434 statement. This subroutine is called when the symbol is seen in a
4435 context that causes it to become redefined. If the symbol is an
4436 iterator, we generate an error message and return nonzero. */
4439 gfc_check_do_variable (gfc_symtree
*st
)
4443 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
4444 if (s
->do_variable
== st
)
4446 gfc_error_now ("Variable %qs at %C cannot be redefined inside "
4447 "loop beginning at %L", st
->name
, &s
->head
->loc
);
4455 /* Checks to see if the current statement label closes an enddo.
4456 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
4457 an error) if it incorrectly closes an ENDDO. */
4460 check_do_closure (void)
4464 if (gfc_statement_label
== NULL
)
4467 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
4468 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4472 return 0; /* No loops to close */
4474 if (p
->ext
.end_do_label
== gfc_statement_label
)
4476 if (p
== gfc_state_stack
)
4479 gfc_error ("End of nonblock DO statement at %C is within another block");
4483 /* At this point, the label doesn't terminate the innermost loop.
4484 Make sure it doesn't terminate another one. */
4485 for (; p
; p
= p
->previous
)
4486 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4487 && p
->ext
.end_do_label
== gfc_statement_label
)
4489 gfc_error ("End of nonblock DO statement at %C is interwoven "
4490 "with another DO loop");
4498 /* Parse a series of contained program units. */
4500 static void parse_progunit (gfc_statement
);
4503 /* Parse a CRITICAL block. */
4506 parse_critical_block (void)
4509 gfc_state_data s
, *sd
;
4512 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4513 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
4514 gfc_error_now (is_oacc (sd
)
4515 ? G_("CRITICAL block inside of OpenACC region at %C")
4516 : G_("CRITICAL block inside of OpenMP region at %C"));
4518 s
.ext
.end_do_label
= new_st
.label1
;
4520 accept_statement (ST_CRITICAL
);
4521 top
= gfc_state_stack
->tail
;
4523 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
4525 d
= add_statement ();
4526 d
->op
= EXEC_CRITICAL
;
4531 st
= parse_executable (ST_NONE
);
4539 case ST_END_CRITICAL
:
4540 if (s
.ext
.end_do_label
!= NULL
4541 && s
.ext
.end_do_label
!= gfc_statement_label
)
4542 gfc_error_now ("Statement label in END CRITICAL at %C does not "
4543 "match CRITICAL label");
4545 if (gfc_statement_label
!= NULL
)
4547 new_st
.op
= EXEC_NOP
;
4553 unexpected_statement (st
);
4557 while (st
!= ST_END_CRITICAL
);
4560 accept_statement (st
);
4564 /* Set up the local namespace for a BLOCK construct. */
4567 gfc_build_block_ns (gfc_namespace
*parent_ns
)
4569 gfc_namespace
* my_ns
;
4570 static int numblock
= 1;
4572 my_ns
= gfc_get_namespace (parent_ns
, 1);
4573 my_ns
->construct_entities
= 1;
4575 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
4576 code generation (so it must not be NULL).
4577 We set its recursive argument if our container procedure is recursive, so
4578 that local variables are accordingly placed on the stack when it
4579 will be necessary. */
4581 my_ns
->proc_name
= gfc_new_block
;
4585 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
4587 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
4588 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
4589 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
4590 my_ns
->proc_name
->name
, NULL
);
4592 gfc_commit_symbol (my_ns
->proc_name
);
4595 if (parent_ns
->proc_name
)
4596 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
4602 /* Parse a BLOCK construct. */
4605 parse_block_construct (void)
4607 gfc_namespace
* my_ns
;
4608 gfc_namespace
* my_parent
;
4611 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
4613 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4615 new_st
.op
= EXEC_BLOCK
;
4616 new_st
.ext
.block
.ns
= my_ns
;
4617 new_st
.ext
.block
.assoc
= NULL
;
4618 accept_statement (ST_BLOCK
);
4620 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
4621 gfc_current_ns
= my_ns
;
4622 my_parent
= my_ns
->parent
;
4624 parse_progunit (ST_NONE
);
4626 /* Don't depend on the value of gfc_current_ns; it might have been
4627 reset if the block had errors and was cleaned up. */
4628 gfc_current_ns
= my_parent
;
4634 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
4635 behind the scenes with compiler-generated variables. */
4638 parse_associate (void)
4640 gfc_namespace
* my_ns
;
4643 gfc_association_list
* a
;
4645 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
4647 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4649 new_st
.op
= EXEC_BLOCK
;
4650 new_st
.ext
.block
.ns
= my_ns
;
4651 gcc_assert (new_st
.ext
.block
.assoc
);
4653 /* Add all associate-names as BLOCK variables. Creating them is enough
4654 for now, they'll get their values during trans-* phase. */
4655 gfc_current_ns
= my_ns
;
4656 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
4660 gfc_array_ref
*array_ref
;
4662 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
4666 sym
->attr
.flavor
= FL_VARIABLE
;
4668 sym
->declared_at
= a
->where
;
4669 gfc_set_sym_referenced (sym
);
4671 /* Initialize the typespec. It is not available in all cases,
4672 however, as it may only be set on the target during resolution.
4673 Still, sometimes it helps to have it right now -- especially
4674 for parsing component references on the associate-name
4675 in case of association to a derived-type. */
4676 sym
->ts
= a
->target
->ts
;
4678 /* Check if the target expression is array valued. This cannot always
4679 be done by looking at target.rank, because that might not have been
4680 set yet. Therefore traverse the chain of refs, looking for the last
4681 array ref and evaluate that. */
4683 for (ref
= a
->target
->ref
; ref
; ref
= ref
->next
)
4684 if (ref
->type
== REF_ARRAY
)
4685 array_ref
= &ref
->u
.ar
;
4686 if (array_ref
|| a
->target
->rank
)
4693 /* Count the dimension, that have a non-scalar extend. */
4694 for (dim
= 0; dim
< array_ref
->dimen
; ++dim
)
4695 if (array_ref
->dimen_type
[dim
] != DIMEN_ELEMENT
4696 && !(array_ref
->dimen_type
[dim
] == DIMEN_UNKNOWN
4697 && array_ref
->end
[dim
] == NULL
4698 && array_ref
->start
[dim
] != NULL
))
4702 rank
= a
->target
->rank
;
4703 /* When the rank is greater than zero then sym will be an array. */
4704 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
4706 if ((!CLASS_DATA (sym
)->as
&& rank
!= 0)
4707 || (CLASS_DATA (sym
)->as
4708 && CLASS_DATA (sym
)->as
->rank
!= rank
))
4710 /* Don't just (re-)set the attr and as in the sym.ts,
4711 because this modifies the target's attr and as. Copy the
4712 data and do a build_class_symbol. */
4713 symbol_attribute attr
= CLASS_DATA (a
->target
)->attr
;
4714 int corank
= gfc_get_corank (a
->target
);
4719 as
= gfc_get_array_spec ();
4720 as
->type
= AS_DEFERRED
;
4722 as
->corank
= corank
;
4723 attr
.dimension
= rank
? 1 : 0;
4724 attr
.codimension
= corank
? 1 : 0;
4729 attr
.dimension
= attr
.codimension
= 0;
4732 type
= CLASS_DATA (sym
)->ts
;
4733 if (!gfc_build_class_symbol (&type
,
4737 sym
->ts
.type
= BT_CLASS
;
4738 sym
->attr
.class_ok
= 1;
4741 sym
->attr
.class_ok
= 1;
4743 else if ((!sym
->as
&& rank
!= 0)
4744 || (sym
->as
&& sym
->as
->rank
!= rank
))
4746 as
= gfc_get_array_spec ();
4747 as
->type
= AS_DEFERRED
;
4749 as
->corank
= gfc_get_corank (a
->target
);
4751 sym
->attr
.dimension
= 1;
4753 sym
->attr
.codimension
= 1;
4758 accept_statement (ST_ASSOCIATE
);
4759 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
4762 st
= parse_executable (ST_NONE
);
4769 accept_statement (st
);
4770 my_ns
->code
= gfc_state_stack
->head
;
4774 unexpected_statement (st
);
4778 gfc_current_ns
= gfc_current_ns
->parent
;
4783 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
4784 handled inside of parse_executable(), because they aren't really
4788 parse_do_block (void)
4797 s
.ext
.end_do_label
= new_st
.label1
;
4799 if (new_st
.ext
.iterator
!= NULL
)
4801 stree
= new_st
.ext
.iterator
->var
->symtree
;
4802 if (directive_unroll
!= -1)
4804 new_st
.ext
.iterator
->unroll
= directive_unroll
;
4805 directive_unroll
= -1;
4807 if (directive_ivdep
)
4809 new_st
.ext
.iterator
->ivdep
= directive_ivdep
;
4810 directive_ivdep
= false;
4812 if (directive_vector
)
4814 new_st
.ext
.iterator
->vector
= directive_vector
;
4815 directive_vector
= false;
4817 if (directive_novector
)
4819 new_st
.ext
.iterator
->novector
= directive_novector
;
4820 directive_novector
= false;
4826 accept_statement (ST_DO
);
4828 top
= gfc_state_stack
->tail
;
4829 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
4832 s
.do_variable
= stree
;
4834 top
->block
= new_level (top
);
4835 top
->block
->op
= EXEC_DO
;
4838 st
= parse_executable (ST_NONE
);
4846 if (s
.ext
.end_do_label
!= NULL
4847 && s
.ext
.end_do_label
!= gfc_statement_label
)
4848 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
4851 if (gfc_statement_label
!= NULL
)
4853 new_st
.op
= EXEC_NOP
;
4858 case ST_IMPLIED_ENDDO
:
4859 /* If the do-stmt of this DO construct has a do-construct-name,
4860 the corresponding end-do must be an end-do-stmt (with a matching
4861 name, but in that case we must have seen ST_ENDDO first).
4862 We only complain about this in pedantic mode. */
4863 if (gfc_current_block () != NULL
)
4864 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
4865 &gfc_current_block()->declared_at
);
4870 unexpected_statement (st
);
4875 accept_statement (st
);
4879 /* Parse the statements of OpenMP do/parallel do. */
4881 static gfc_statement
4882 parse_omp_do (gfc_statement omp_st
)
4888 accept_statement (omp_st
);
4890 cp
= gfc_state_stack
->tail
;
4891 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4892 np
= new_level (cp
);
4898 st
= next_statement ();
4901 else if (st
== ST_DO
)
4904 unexpected_statement (st
);
4908 if (gfc_statement_label
!= NULL
4909 && gfc_state_stack
->previous
!= NULL
4910 && gfc_state_stack
->previous
->state
== COMP_DO
4911 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4919 there should be no !$OMP END DO. */
4921 return ST_IMPLIED_ENDDO
;
4924 check_do_closure ();
4927 st
= next_statement ();
4928 gfc_statement omp_end_st
= ST_OMP_END_DO
;
4931 case ST_OMP_DISTRIBUTE
: omp_end_st
= ST_OMP_END_DISTRIBUTE
; break;
4932 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4933 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4935 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4936 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4938 case ST_OMP_DISTRIBUTE_SIMD
:
4939 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4941 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
4942 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
4943 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
4944 case ST_OMP_PARALLEL_DO_SIMD
:
4945 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
4947 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
4948 case ST_OMP_TARGET_PARALLEL_DO
:
4949 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO
;
4951 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
4952 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO_SIMD
;
4954 case ST_OMP_TARGET_SIMD
: omp_end_st
= ST_OMP_END_TARGET_SIMD
; break;
4955 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
4956 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
4958 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4959 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4961 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4962 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4964 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
4965 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
4967 case ST_OMP_TASKLOOP
: omp_end_st
= ST_OMP_END_TASKLOOP
; break;
4968 case ST_OMP_TASKLOOP_SIMD
: omp_end_st
= ST_OMP_END_TASKLOOP_SIMD
; break;
4969 case ST_OMP_TEAMS_DISTRIBUTE
:
4970 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
4972 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
4973 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
4975 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
4976 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
4978 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
4979 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
4981 default: gcc_unreachable ();
4983 if (st
== omp_end_st
)
4985 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
4986 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
4988 gcc_assert (new_st
.op
== EXEC_NOP
);
4989 gfc_clear_new_st ();
4990 gfc_commit_symbols ();
4991 gfc_warning_check ();
4992 st
= next_statement ();
4998 /* Parse the statements of OpenMP atomic directive. */
5000 static gfc_statement
5001 parse_omp_oacc_atomic (bool omp_p
)
5003 gfc_statement st
, st_atomic
, st_end_atomic
;
5010 st_atomic
= ST_OMP_ATOMIC
;
5011 st_end_atomic
= ST_OMP_END_ATOMIC
;
5015 st_atomic
= ST_OACC_ATOMIC
;
5016 st_end_atomic
= ST_OACC_END_ATOMIC
;
5018 accept_statement (st_atomic
);
5020 cp
= gfc_state_stack
->tail
;
5021 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5022 np
= new_level (cp
);
5025 np
->ext
.omp_atomic
= cp
->ext
.omp_atomic
;
5026 count
= 1 + ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
5027 == GFC_OMP_ATOMIC_CAPTURE
);
5031 st
= next_statement ();
5034 else if (st
== ST_ASSIGNMENT
)
5036 accept_statement (st
);
5040 unexpected_statement (st
);
5045 st
= next_statement ();
5046 if (st
== st_end_atomic
)
5048 gfc_clear_new_st ();
5049 gfc_commit_symbols ();
5050 gfc_warning_check ();
5051 st
= next_statement ();
5053 else if ((cp
->ext
.omp_atomic
& GFC_OMP_ATOMIC_MASK
)
5054 == GFC_OMP_ATOMIC_CAPTURE
)
5055 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
5060 /* Parse the statements of an OpenACC structured block. */
5063 parse_oacc_structured_block (gfc_statement acc_st
)
5065 gfc_statement st
, acc_end_st
;
5067 gfc_state_data s
, *sd
;
5069 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
5070 if (sd
->state
== COMP_CRITICAL
)
5071 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5073 accept_statement (acc_st
);
5075 cp
= gfc_state_stack
->tail
;
5076 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5077 np
= new_level (cp
);
5082 case ST_OACC_PARALLEL
:
5083 acc_end_st
= ST_OACC_END_PARALLEL
;
5085 case ST_OACC_KERNELS
:
5086 acc_end_st
= ST_OACC_END_KERNELS
;
5088 case ST_OACC_SERIAL
:
5089 acc_end_st
= ST_OACC_END_SERIAL
;
5092 acc_end_st
= ST_OACC_END_DATA
;
5094 case ST_OACC_HOST_DATA
:
5095 acc_end_st
= ST_OACC_END_HOST_DATA
;
5103 st
= parse_executable (ST_NONE
);
5106 else if (st
!= acc_end_st
)
5108 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
5109 reject_statement ();
5112 while (st
!= acc_end_st
);
5114 gcc_assert (new_st
.op
== EXEC_NOP
);
5116 gfc_clear_new_st ();
5117 gfc_commit_symbols ();
5118 gfc_warning_check ();
5122 /* Parse the statements of OpenACC 'loop', or combined compute 'loop'. */
5124 static gfc_statement
5125 parse_oacc_loop (gfc_statement acc_st
)
5129 gfc_state_data s
, *sd
;
5131 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
5132 if (sd
->state
== COMP_CRITICAL
)
5133 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5135 accept_statement (acc_st
);
5137 cp
= gfc_state_stack
->tail
;
5138 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5139 np
= new_level (cp
);
5145 st
= next_statement ();
5148 else if (st
== ST_DO
)
5152 gfc_error ("Expected DO loop at %C");
5153 reject_statement ();
5158 if (gfc_statement_label
!= NULL
5159 && gfc_state_stack
->previous
!= NULL
5160 && gfc_state_stack
->previous
->state
== COMP_DO
5161 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
5164 return ST_IMPLIED_ENDDO
;
5167 check_do_closure ();
5170 st
= next_statement ();
5171 if (st
== ST_OACC_END_LOOP
)
5172 gfc_warning (0, "Redundant !$ACC END LOOP at %C");
5173 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
5174 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
5175 (acc_st
== ST_OACC_SERIAL_LOOP
&& st
== ST_OACC_END_SERIAL_LOOP
) ||
5176 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
5178 gcc_assert (new_st
.op
== EXEC_NOP
);
5179 gfc_clear_new_st ();
5180 gfc_commit_symbols ();
5181 gfc_warning_check ();
5182 st
= next_statement ();
5188 /* Parse the statements of an OpenMP structured block. */
5191 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
5193 gfc_statement st
, omp_end_st
;
5197 accept_statement (omp_st
);
5199 cp
= gfc_state_stack
->tail
;
5200 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5201 np
= new_level (cp
);
5207 case ST_OMP_PARALLEL
:
5208 omp_end_st
= ST_OMP_END_PARALLEL
;
5210 case ST_OMP_PARALLEL_SECTIONS
:
5211 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
5213 case ST_OMP_SECTIONS
:
5214 omp_end_st
= ST_OMP_END_SECTIONS
;
5216 case ST_OMP_ORDERED
:
5217 omp_end_st
= ST_OMP_END_ORDERED
;
5219 case ST_OMP_CRITICAL
:
5220 omp_end_st
= ST_OMP_END_CRITICAL
;
5223 omp_end_st
= ST_OMP_END_MASTER
;
5226 omp_end_st
= ST_OMP_END_SINGLE
;
5229 omp_end_st
= ST_OMP_END_TARGET
;
5231 case ST_OMP_TARGET_DATA
:
5232 omp_end_st
= ST_OMP_END_TARGET_DATA
;
5234 case ST_OMP_TARGET_PARALLEL
:
5235 omp_end_st
= ST_OMP_END_TARGET_PARALLEL
;
5237 case ST_OMP_TARGET_TEAMS
:
5238 omp_end_st
= ST_OMP_END_TARGET_TEAMS
;
5240 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5241 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
5243 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5244 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5246 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5247 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5249 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5250 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
5253 omp_end_st
= ST_OMP_END_TASK
;
5255 case ST_OMP_TASKGROUP
:
5256 omp_end_st
= ST_OMP_END_TASKGROUP
;
5259 omp_end_st
= ST_OMP_END_TEAMS
;
5261 case ST_OMP_TEAMS_DISTRIBUTE
:
5262 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
5264 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5265 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5267 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5268 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5270 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5271 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
5273 case ST_OMP_DISTRIBUTE
:
5274 omp_end_st
= ST_OMP_END_DISTRIBUTE
;
5276 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5277 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
5279 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5280 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
5282 case ST_OMP_DISTRIBUTE_SIMD
:
5283 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
5285 case ST_OMP_WORKSHARE
:
5286 omp_end_st
= ST_OMP_END_WORKSHARE
;
5288 case ST_OMP_PARALLEL_WORKSHARE
:
5289 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
5297 if (workshare_stmts_only
)
5299 /* Inside of !$omp workshare, only
5302 where statements and constructs
5303 forall statements and constructs
5307 are allowed. For !$omp critical these
5308 restrictions apply recursively. */
5311 st
= next_statement ();
5322 accept_statement (st
);
5325 case ST_WHERE_BLOCK
:
5326 parse_where_block ();
5329 case ST_FORALL_BLOCK
:
5330 parse_forall_block ();
5333 case ST_OMP_PARALLEL
:
5334 case ST_OMP_PARALLEL_SECTIONS
:
5335 parse_omp_structured_block (st
, false);
5338 case ST_OMP_PARALLEL_WORKSHARE
:
5339 case ST_OMP_CRITICAL
:
5340 parse_omp_structured_block (st
, true);
5343 case ST_OMP_PARALLEL_DO
:
5344 case ST_OMP_PARALLEL_DO_SIMD
:
5345 st
= parse_omp_do (st
);
5349 st
= parse_omp_oacc_atomic (true);
5360 st
= next_statement ();
5364 st
= parse_executable (ST_NONE
);
5367 else if (st
== ST_OMP_SECTION
5368 && (omp_st
== ST_OMP_SECTIONS
5369 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
5371 np
= new_level (np
);
5375 else if (st
!= omp_end_st
)
5376 unexpected_statement (st
);
5378 while (st
!= omp_end_st
);
5382 case EXEC_OMP_END_NOWAIT
:
5383 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
5385 case EXEC_OMP_END_CRITICAL
:
5386 if (((cp
->ext
.omp_clauses
== NULL
) ^ (new_st
.ext
.omp_name
== NULL
))
5387 || (new_st
.ext
.omp_name
!= NULL
5388 && strcmp (cp
->ext
.omp_clauses
->critical_name
,
5389 new_st
.ext
.omp_name
) != 0))
5390 gfc_error ("Name after !$omp critical and !$omp end critical does "
5392 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
5393 new_st
.ext
.omp_name
= NULL
;
5395 case EXEC_OMP_END_SINGLE
:
5396 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
5397 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
5398 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
5399 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
5407 gfc_clear_new_st ();
5408 gfc_commit_symbols ();
5409 gfc_warning_check ();
5414 /* Accept a series of executable statements. We return the first
5415 statement that doesn't fit to the caller. Any block statements are
5416 passed on to the correct handler, which usually passes the buck
5419 static gfc_statement
5420 parse_executable (gfc_statement st
)
5425 st
= next_statement ();
5429 close_flag
= check_do_closure ();
5434 case ST_END_PROGRAM
:
5437 case ST_END_FUNCTION
:
5442 case ST_END_SUBROUTINE
:
5447 case ST_SELECT_CASE
:
5448 gfc_error ("%s statement at %C cannot terminate a non-block "
5449 "DO loop", gfc_ascii_statement (st
));
5462 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
5463 "first executable statement");
5469 accept_statement (st
);
5470 if (close_flag
== 1)
5471 return ST_IMPLIED_ENDDO
;
5475 parse_block_construct ();
5486 case ST_SELECT_CASE
:
5487 parse_select_block ();
5490 case ST_SELECT_TYPE
:
5491 parse_select_type_block ();
5494 case ST_SELECT_RANK
:
5495 parse_select_rank_block ();
5500 if (check_do_closure () == 1)
5501 return ST_IMPLIED_ENDDO
;
5505 parse_critical_block ();
5508 case ST_WHERE_BLOCK
:
5509 parse_where_block ();
5512 case ST_FORALL_BLOCK
:
5513 parse_forall_block ();
5516 case ST_OACC_PARALLEL_LOOP
:
5517 case ST_OACC_KERNELS_LOOP
:
5518 case ST_OACC_SERIAL_LOOP
:
5520 st
= parse_oacc_loop (st
);
5521 if (st
== ST_IMPLIED_ENDDO
)
5525 case ST_OACC_PARALLEL
:
5526 case ST_OACC_KERNELS
:
5527 case ST_OACC_SERIAL
:
5529 case ST_OACC_HOST_DATA
:
5530 parse_oacc_structured_block (st
);
5533 case ST_OMP_PARALLEL
:
5534 case ST_OMP_PARALLEL_SECTIONS
:
5535 case ST_OMP_SECTIONS
:
5536 case ST_OMP_ORDERED
:
5537 case ST_OMP_CRITICAL
:
5541 case ST_OMP_TARGET_DATA
:
5542 case ST_OMP_TARGET_PARALLEL
:
5543 case ST_OMP_TARGET_TEAMS
:
5546 case ST_OMP_TASKGROUP
:
5547 parse_omp_structured_block (st
, false);
5550 case ST_OMP_WORKSHARE
:
5551 case ST_OMP_PARALLEL_WORKSHARE
:
5552 parse_omp_structured_block (st
, true);
5555 case ST_OMP_DISTRIBUTE
:
5556 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5557 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5558 case ST_OMP_DISTRIBUTE_SIMD
:
5560 case ST_OMP_DO_SIMD
:
5561 case ST_OMP_PARALLEL_DO
:
5562 case ST_OMP_PARALLEL_DO_SIMD
:
5564 case ST_OMP_TARGET_PARALLEL_DO
:
5565 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
5566 case ST_OMP_TARGET_SIMD
:
5567 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5568 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5569 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5570 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5571 case ST_OMP_TASKLOOP
:
5572 case ST_OMP_TASKLOOP_SIMD
:
5573 case ST_OMP_TEAMS_DISTRIBUTE
:
5574 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5575 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5576 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5577 st
= parse_omp_do (st
);
5578 if (st
== ST_IMPLIED_ENDDO
)
5582 case ST_OACC_ATOMIC
:
5583 st
= parse_omp_oacc_atomic (false);
5587 st
= parse_omp_oacc_atomic (true);
5594 if (directive_unroll
!= -1)
5595 gfc_error ("%<GCC unroll%> directive not at the start of a loop at %C");
5597 if (directive_ivdep
)
5598 gfc_error ("%<GCC ivdep%> directive not at the start of a loop at %C");
5600 if (directive_vector
)
5601 gfc_error ("%<GCC vector%> directive not at the start of a loop at %C");
5603 if (directive_novector
)
5604 gfc_error ("%<GCC novector%> "
5605 "directive not at the start of a loop at %C");
5607 st
= next_statement ();
5612 /* Fix the symbols for sibling functions. These are incorrectly added to
5613 the child namespace as the parser didn't know about this procedure. */
5616 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
5620 gfc_symbol
*old_sym
;
5622 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
5624 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
5626 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
5627 goto fixup_contained
;
5629 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
5630 && sym
->attr
.generic
&& sym
->attr
.function
)
5631 ||(sym
->attr
.flavor
== FL_DERIVED
5632 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
5633 goto fixup_contained
;
5635 old_sym
= st
->n
.sym
;
5636 if (old_sym
->ns
== ns
5637 && !old_sym
->attr
.contained
5639 /* By 14.6.1.3, host association should be excluded
5640 for the following. */
5641 && !(old_sym
->attr
.external
5642 || (old_sym
->ts
.type
!= BT_UNKNOWN
5643 && !old_sym
->attr
.implicit_type
)
5644 || old_sym
->attr
.flavor
== FL_PARAMETER
5645 || old_sym
->attr
.use_assoc
5646 || old_sym
->attr
.in_common
5647 || old_sym
->attr
.in_equivalence
5648 || old_sym
->attr
.data
5649 || old_sym
->attr
.dummy
5650 || old_sym
->attr
.result
5651 || old_sym
->attr
.dimension
5652 || old_sym
->attr
.allocatable
5653 || old_sym
->attr
.intrinsic
5654 || old_sym
->attr
.generic
5655 || old_sym
->attr
.flavor
== FL_NAMELIST
5656 || old_sym
->attr
.flavor
== FL_LABEL
5657 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
5659 /* Replace it with the symbol from the parent namespace. */
5663 gfc_release_symbol (old_sym
);
5667 /* Do the same for any contained procedures. */
5668 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
5673 parse_contained (int module
)
5675 gfc_namespace
*ns
, *parent_ns
, *tmp
;
5676 gfc_state_data s1
, s2
;
5681 int contains_statements
= 0;
5684 push_state (&s1
, COMP_CONTAINS
, NULL
);
5685 parent_ns
= gfc_current_ns
;
5689 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
5691 gfc_current_ns
->sibling
= parent_ns
->contained
;
5692 parent_ns
->contained
= gfc_current_ns
;
5695 /* Process the next available statement. We come here if we got an error
5696 and rejected the last statement. */
5697 old_loc
= gfc_current_locus
;
5698 st
= next_statement ();
5707 contains_statements
= 1;
5708 accept_statement (st
);
5711 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
5714 /* For internal procedures, create/update the symbol in the
5715 parent namespace. */
5719 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
5720 gfc_error ("Contained procedure %qs at %C is already "
5721 "ambiguous", gfc_new_block
->name
);
5724 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
5726 &gfc_new_block
->declared_at
))
5728 if (st
== ST_FUNCTION
)
5729 gfc_add_function (&sym
->attr
, sym
->name
,
5730 &gfc_new_block
->declared_at
);
5732 gfc_add_subroutine (&sym
->attr
, sym
->name
,
5733 &gfc_new_block
->declared_at
);
5737 gfc_commit_symbols ();
5740 sym
= gfc_new_block
;
5742 /* Mark this as a contained function, so it isn't replaced
5743 by other module functions. */
5744 sym
->attr
.contained
= 1;
5746 /* Set implicit_pure so that it can be reset if any of the
5747 tests for purity fail. This is used for some optimisation
5748 during translation. */
5749 if (!sym
->attr
.pure
)
5750 sym
->attr
.implicit_pure
= 1;
5752 parse_progunit (ST_NONE
);
5754 /* Fix up any sibling functions that refer to this one. */
5755 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
5756 /* Or refer to any of its alternate entry points. */
5757 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
5758 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
5760 gfc_current_ns
->code
= s2
.head
;
5761 gfc_current_ns
= parent_ns
;
5766 /* These statements are associated with the end of the host unit. */
5767 case ST_END_FUNCTION
:
5769 case ST_END_SUBMODULE
:
5770 case ST_END_PROGRAM
:
5771 case ST_END_SUBROUTINE
:
5772 accept_statement (st
);
5773 gfc_current_ns
->code
= s1
.head
;
5777 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
5778 gfc_ascii_statement (st
));
5779 reject_statement ();
5785 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
5786 && st
!= ST_END_MODULE
&& st
!= ST_END_SUBMODULE
5787 && st
!= ST_END_PROGRAM
);
5789 /* The first namespace in the list is guaranteed to not have
5790 anything (worthwhile) in it. */
5791 tmp
= gfc_current_ns
;
5792 gfc_current_ns
= parent_ns
;
5793 if (seen_error
&& tmp
->refs
> 1)
5794 gfc_free_namespace (tmp
);
5796 ns
= gfc_current_ns
->contained
;
5797 gfc_current_ns
->contained
= ns
->sibling
;
5798 gfc_free_namespace (ns
);
5801 if (!contains_statements
)
5802 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
5803 "FUNCTION or SUBROUTINE statement at %L", &old_loc
);
5807 /* The result variable in a MODULE PROCEDURE needs to be created and
5808 its characteristics copied from the interface since it is neither
5809 declared in the procedure declaration nor in the specification
5813 get_modproc_result (void)
5816 if (gfc_state_stack
->previous
5817 && gfc_state_stack
->previous
->state
== COMP_CONTAINS
5818 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
5820 proc
= gfc_current_ns
->proc_name
? gfc_current_ns
->proc_name
: NULL
;
5822 && proc
->attr
.function
5824 && proc
->tlink
->result
5825 && proc
->tlink
->result
!= proc
->tlink
)
5827 gfc_copy_dummy_sym (&proc
->result
, proc
->tlink
->result
, 1);
5828 gfc_set_sym_referenced (proc
->result
);
5829 proc
->result
->attr
.if_source
= IFSRC_DECL
;
5830 gfc_commit_symbol (proc
->result
);
5836 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
5839 parse_progunit (gfc_statement st
)
5844 gfc_adjust_builtins ();
5847 && gfc_new_block
->abr_modproc_decl
5848 && gfc_new_block
->attr
.function
)
5849 get_modproc_result ();
5851 st
= parse_spec (st
);
5858 /* This is not allowed within BLOCK! */
5859 if (gfc_current_state () != COMP_BLOCK
)
5864 accept_statement (st
);
5871 if (gfc_current_state () == COMP_FUNCTION
)
5872 gfc_check_function_type (gfc_current_ns
);
5877 st
= parse_executable (st
);
5885 /* This is not allowed within BLOCK! */
5886 if (gfc_current_state () != COMP_BLOCK
)
5891 accept_statement (st
);
5898 unexpected_statement (st
);
5899 reject_statement ();
5900 st
= next_statement ();
5906 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
5907 if (p
->state
== COMP_CONTAINS
)
5910 if (gfc_find_state (COMP_MODULE
) == true
5911 || gfc_find_state (COMP_SUBMODULE
) == true)
5916 gfc_error ("CONTAINS statement at %C is already in a contained "
5918 reject_statement ();
5919 st
= next_statement ();
5923 parse_contained (0);
5926 gfc_current_ns
->code
= gfc_state_stack
->head
;
5930 /* Come here to complain about a global symbol already in use as
5934 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
5939 where
= &gfc_current_locus
;
5949 case GSYM_SUBROUTINE
:
5950 name
= "SUBROUTINE";
5955 case GSYM_BLOCK_DATA
:
5956 name
= "BLOCK DATA";
5967 if (sym
->binding_label
)
5968 gfc_error ("Global binding name %qs at %L is already being used "
5969 "as a %s at %L", sym
->binding_label
, where
, name
,
5972 gfc_error ("Global name %qs at %L is already being used as "
5973 "a %s at %L", sym
->name
, where
, name
, &sym
->where
);
5977 if (sym
->binding_label
)
5978 gfc_error ("Global binding name %qs at %L is already being used "
5979 "at %L", sym
->binding_label
, where
, &sym
->where
);
5981 gfc_error ("Global name %qs at %L is already being used at %L",
5982 sym
->name
, where
, &sym
->where
);
5987 /* Parse a block data program unit. */
5990 parse_block_data (void)
5993 static locus blank_locus
;
5994 static int blank_block
=0;
5997 gfc_current_ns
->proc_name
= gfc_new_block
;
5998 gfc_current_ns
->is_block_data
= 1;
6000 if (gfc_new_block
== NULL
)
6003 gfc_error ("Blank BLOCK DATA at %C conflicts with "
6004 "prior BLOCK DATA at %L", &blank_locus
);
6008 blank_locus
= gfc_current_locus
;
6013 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6015 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
6016 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6019 s
->type
= GSYM_BLOCK_DATA
;
6020 s
->where
= gfc_new_block
->declared_at
;
6025 st
= parse_spec (ST_NONE
);
6027 while (st
!= ST_END_BLOCK_DATA
)
6029 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
6030 gfc_ascii_statement (st
));
6031 reject_statement ();
6032 st
= next_statement ();
6037 /* Following the association of the ancestor (sub)module symbols, they
6038 must be set host rather than use associated and all must be public.
6039 They are flagged up by 'used_in_submodule' so that they can be set
6040 DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
6041 linker chokes on multiple symbol definitions. */
6044 set_syms_host_assoc (gfc_symbol
*sym
)
6047 const char dot
[2] = ".";
6048 /* Symbols take the form module.submodule_ or module.name_. */
6049 char parent1
[2 * GFC_MAX_SYMBOL_LEN
+ 2];
6050 char parent2
[2 * GFC_MAX_SYMBOL_LEN
+ 2];
6055 if (sym
->attr
.module_procedure
)
6056 sym
->attr
.external
= 0;
6058 sym
->attr
.use_assoc
= 0;
6059 sym
->attr
.host_assoc
= 1;
6060 sym
->attr
.used_in_submodule
=1;
6062 if (sym
->attr
.flavor
== FL_DERIVED
)
6064 /* Derived types with PRIVATE components that are declared in
6065 modules other than the parent module must not be changed to be
6066 PUBLIC. The 'use-assoc' attribute must be reset so that the
6067 test in symbol.c(gfc_find_component) works correctly. This is
6068 not necessary for PRIVATE symbols since they are not read from
6070 memset(parent1
, '\0', sizeof(parent1
));
6071 memset(parent2
, '\0', sizeof(parent2
));
6072 strcpy (parent1
, gfc_new_block
->name
);
6073 strcpy (parent2
, sym
->module
);
6074 if (strcmp (strtok (parent1
, dot
), strtok (parent2
, dot
)) == 0)
6076 for (c
= sym
->components
; c
; c
= c
->next
)
6077 c
->attr
.access
= ACCESS_PUBLIC
;
6081 sym
->attr
.use_assoc
= 1;
6082 sym
->attr
.host_assoc
= 0;
6087 /* Parse a module subprogram. */
6096 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6097 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
6098 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6101 s
->type
= GSYM_MODULE
;
6102 s
->where
= gfc_new_block
->declared_at
;
6106 /* Something is nulling the module_list after this point. This is good
6107 since it allows us to 'USE' the parent modules that the submodule
6108 inherits and to set (most) of the symbols as host associated. */
6109 if (gfc_current_state () == COMP_SUBMODULE
)
6112 gfc_traverse_ns (gfc_current_ns
, set_syms_host_assoc
);
6115 st
= parse_spec (ST_NONE
);
6125 parse_contained (1);
6129 case ST_END_SUBMODULE
:
6130 accept_statement (st
);
6134 gfc_error ("Unexpected %s statement in MODULE at %C",
6135 gfc_ascii_statement (st
));
6138 reject_statement ();
6139 st
= next_statement ();
6143 /* Make sure not to free the namespace twice on error. */
6145 s
->ns
= gfc_current_ns
;
6149 /* Add a procedure name to the global symbol table. */
6152 add_global_procedure (bool sub
)
6156 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6157 name is a global identifier. */
6158 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
6160 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6163 || (s
->type
!= GSYM_UNKNOWN
6164 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
6166 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6167 /* Silence follow-up errors. */
6168 gfc_new_block
->binding_label
= NULL
;
6172 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6173 s
->sym_name
= gfc_new_block
->name
;
6174 s
->where
= gfc_new_block
->declared_at
;
6176 s
->ns
= gfc_current_ns
;
6180 /* Don't add the symbol multiple times. */
6181 if (gfc_new_block
->binding_label
6182 && (!gfc_notification_std (GFC_STD_F2008
)
6183 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
6185 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
, true);
6188 || (s
->type
!= GSYM_UNKNOWN
6189 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
6191 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6192 /* Silence follow-up errors. */
6193 gfc_new_block
->binding_label
= NULL
;
6197 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6198 s
->sym_name
= gfc_new_block
->name
;
6199 s
->binding_label
= gfc_new_block
->binding_label
;
6200 s
->where
= gfc_new_block
->declared_at
;
6202 s
->ns
= gfc_current_ns
;
6208 /* Add a program to the global symbol table. */
6211 add_global_program (void)
6215 if (gfc_new_block
== NULL
)
6217 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6219 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
6220 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6223 s
->type
= GSYM_PROGRAM
;
6224 s
->where
= gfc_new_block
->declared_at
;
6226 s
->ns
= gfc_current_ns
;
6231 /* Resolve all the program units. */
6233 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
6235 gfc_derived_types
= NULL
;
6236 gfc_current_ns
= gfc_global_ns_list
;
6237 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6239 if (gfc_current_ns
->proc_name
6240 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6241 continue; /* Already resolved. */
6243 if (gfc_current_ns
->proc_name
)
6244 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6245 gfc_resolve (gfc_current_ns
);
6246 gfc_current_ns
->derived_types
= gfc_derived_types
;
6247 gfc_derived_types
= NULL
;
6253 clean_up_modules (gfc_gsymbol
*gsym
)
6258 clean_up_modules (gsym
->left
);
6259 clean_up_modules (gsym
->right
);
6261 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
6264 gfc_current_ns
= gsym
->ns
;
6265 gfc_derived_types
= gfc_current_ns
->derived_types
;
6272 /* Translate all the program units. This could be in a different order
6273 to resolution if there are forward references in the file. */
6275 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
6279 gfc_current_ns
= gfc_global_ns_list
;
6280 gfc_get_errors (NULL
, &errors
);
6282 /* We first translate all modules to make sure that later parts
6283 of the program can use the decl. Then we translate the nonmodules. */
6285 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6287 if (!gfc_current_ns
->proc_name
6288 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6291 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6292 gfc_derived_types
= gfc_current_ns
->derived_types
;
6293 gfc_generate_module_code (gfc_current_ns
);
6294 gfc_current_ns
->translated
= 1;
6297 gfc_current_ns
= gfc_global_ns_list
;
6298 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6300 if (gfc_current_ns
->proc_name
6301 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6304 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6305 gfc_derived_types
= gfc_current_ns
->derived_types
;
6306 gfc_generate_code (gfc_current_ns
);
6307 gfc_current_ns
->translated
= 1;
6310 /* Clean up all the namespaces after translation. */
6311 gfc_current_ns
= gfc_global_ns_list
;
6312 for (;gfc_current_ns
;)
6316 if (gfc_current_ns
->proc_name
6317 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6319 gfc_current_ns
= gfc_current_ns
->sibling
;
6323 ns
= gfc_current_ns
->sibling
;
6324 gfc_derived_types
= gfc_current_ns
->derived_types
;
6326 gfc_current_ns
= ns
;
6329 clean_up_modules (gfc_gsym_root
);
6333 /* Top level parser. */
6336 gfc_parse_file (void)
6338 int seen_program
, errors_before
, errors
;
6339 gfc_state_data top
, s
;
6342 gfc_namespace
*next
;
6344 gfc_start_source_files ();
6346 top
.state
= COMP_NONE
;
6348 top
.previous
= NULL
;
6349 top
.head
= top
.tail
= NULL
;
6350 top
.do_variable
= NULL
;
6352 gfc_state_stack
= &top
;
6354 gfc_clear_new_st ();
6356 gfc_statement_label
= NULL
;
6358 if (setjmp (eof_buf
))
6359 return false; /* Come here on unexpected EOF */
6361 /* Prepare the global namespace that will contain the
6363 gfc_global_ns_list
= next
= NULL
;
6368 /* Exit early for empty files. */
6372 in_specification_block
= true;
6375 st
= next_statement ();
6384 goto duplicate_main
;
6386 prog_locus
= gfc_current_locus
;
6388 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
6389 main_program_symbol (gfc_current_ns
, gfc_new_block
->name
);
6390 accept_statement (st
);
6391 add_global_program ();
6392 parse_progunit (ST_NONE
);
6396 add_global_procedure (true);
6397 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
6398 accept_statement (st
);
6399 parse_progunit (ST_NONE
);
6403 add_global_procedure (false);
6404 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
6405 accept_statement (st
);
6406 parse_progunit (ST_NONE
);
6410 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
6411 accept_statement (st
);
6412 parse_block_data ();
6416 push_state (&s
, COMP_MODULE
, gfc_new_block
);
6417 accept_statement (st
);
6419 gfc_get_errors (NULL
, &errors_before
);
6424 push_state (&s
, COMP_SUBMODULE
, gfc_new_block
);
6425 accept_statement (st
);
6427 gfc_get_errors (NULL
, &errors_before
);
6431 /* Anything else starts a nameless main program block. */
6434 goto duplicate_main
;
6436 prog_locus
= gfc_current_locus
;
6438 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
6439 main_program_symbol (gfc_current_ns
, "MAIN__");
6440 parse_progunit (st
);
6444 /* Handle the non-program units. */
6445 gfc_current_ns
->code
= s
.head
;
6447 gfc_resolve (gfc_current_ns
);
6449 /* Dump the parse tree if requested. */
6450 if (flag_dump_fortran_original
)
6451 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6453 gfc_get_errors (NULL
, &errors
);
6454 if (s
.state
== COMP_MODULE
|| s
.state
== COMP_SUBMODULE
)
6456 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
6457 gfc_current_ns
->derived_types
= gfc_derived_types
;
6458 gfc_derived_types
= NULL
;
6464 gfc_generate_code (gfc_current_ns
);
6472 /* The main program and non-contained procedures are put
6473 in the global namespace list, so that they can be processed
6474 later and all their interfaces resolved. */
6475 gfc_current_ns
->code
= s
.head
;
6478 for (; next
->sibling
; next
= next
->sibling
)
6480 next
->sibling
= gfc_current_ns
;
6483 gfc_global_ns_list
= gfc_current_ns
;
6485 next
= gfc_current_ns
;
6491 /* Do the resolution. */
6492 resolve_all_program_units (gfc_global_ns_list
);
6495 /* Fixup for external procedures. */
6496 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
6497 gfc_current_ns
= gfc_current_ns
->sibling
)
6498 gfc_check_externals (gfc_current_ns
);
6500 /* Do the parse tree dump. */
6501 gfc_current_ns
= flag_dump_fortran_original
? gfc_global_ns_list
: NULL
;
6503 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6504 if (!gfc_current_ns
->proc_name
6505 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6507 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6508 fputs ("------------------------------------------\n\n", stdout
);
6511 /* Dump C prototypes. */
6512 if (flag_c_prototypes
|| flag_c_prototypes_external
)
6515 "#include <stddef.h>\n"
6516 "#ifdef __cplusplus\n"
6517 "#include <complex>\n"
6518 "#define __GFORTRAN_FLOAT_COMPLEX std::complex<float>\n"
6519 "#define __GFORTRAN_DOUBLE_COMPLEX std::complex<double>\n"
6520 "#define __GFORTRAN_LONG_DOUBLE_COMPLEX std::complex<long double>\n"
6523 "#define __GFORTRAN_FLOAT_COMPLEX float _Complex\n"
6524 "#define __GFORTRAN_DOUBLE_COMPLEX double _Complex\n"
6525 "#define __GFORTRAN_LONG_DOUBLE_COMPLEX long double _Complex\n"
6529 /* First dump BIND(C) prototypes. */
6530 if (flag_c_prototypes
)
6532 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
6533 gfc_current_ns
= gfc_current_ns
->sibling
)
6534 gfc_dump_c_prototypes (gfc_current_ns
, stdout
);
6537 /* Dump external prototypes. */
6538 if (flag_c_prototypes_external
)
6539 gfc_dump_external_c_prototypes (stdout
);
6541 if (flag_c_prototypes
|| flag_c_prototypes_external
)
6542 fprintf (stdout
, "\n#ifdef __cplusplus\n}\n#endif\n");
6544 /* Do the translation. */
6545 translate_all_program_units (gfc_global_ns_list
);
6547 /* Dump the global symbol ist. We only do this here because part
6548 of it is generated after mangling the identifiers in
6551 if (flag_dump_fortran_global
)
6552 gfc_dump_global_symbols (stdout
);
6554 gfc_end_source_files ();
6558 /* If we see a duplicate main program, shut down. If the second
6559 instance is an implied main program, i.e. data decls or executable
6560 statements, we're in for lots of errors. */
6561 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
6562 reject_statement ();
6567 /* Return true if this state data represents an OpenACC region. */
6569 is_oacc (gfc_state_data
*sd
)
6571 switch (sd
->construct
->op
)
6573 case EXEC_OACC_PARALLEL_LOOP
:
6574 case EXEC_OACC_PARALLEL
:
6575 case EXEC_OACC_KERNELS_LOOP
:
6576 case EXEC_OACC_KERNELS
:
6577 case EXEC_OACC_SERIAL_LOOP
:
6578 case EXEC_OACC_SERIAL
:
6579 case EXEC_OACC_DATA
:
6580 case EXEC_OACC_HOST_DATA
:
6581 case EXEC_OACC_LOOP
:
6582 case EXEC_OACC_UPDATE
:
6583 case EXEC_OACC_WAIT
:
6584 case EXEC_OACC_CACHE
:
6585 case EXEC_OACC_ENTER_DATA
:
6586 case EXEC_OACC_EXIT_DATA
:
6587 case EXEC_OACC_ATOMIC
:
6588 case EXEC_OACC_ROUTINE
: