2 Copyright (C) 2000-2021 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;
642 if (gfc_current_state () == COMP_FUNCTION
643 && gfc_current_block ()->result
->ts
.kind
== -1)
646 old_locus
= gfc_current_locus
;
648 /* General OpenACC directive matching: Instead of testing every possible
649 statement, we eliminate most possibilities by peeking at the
652 c
= gfc_peek_ascii_char ();
657 matcha ("routine", gfc_match_oacc_routine
, ST_OACC_ROUTINE
);
661 gfc_unset_implicit_pure (NULL
);
664 gfc_error_now ("OpenACC directives other than ROUTINE may not appear in PURE "
672 matcha ("atomic", gfc_match_oacc_atomic
, ST_OACC_ATOMIC
);
675 matcha ("cache", gfc_match_oacc_cache
, ST_OACC_CACHE
);
678 matcha ("data", gfc_match_oacc_data
, ST_OACC_DATA
);
679 match ("declare", gfc_match_oacc_declare
, ST_OACC_DECLARE
);
682 matcha ("end atomic", gfc_match_omp_eos_error
, ST_OACC_END_ATOMIC
);
683 matcha ("end data", gfc_match_omp_eos_error
, ST_OACC_END_DATA
);
684 matcha ("end host_data", gfc_match_omp_eos_error
, ST_OACC_END_HOST_DATA
);
685 matcha ("end kernels loop", gfc_match_omp_eos_error
, ST_OACC_END_KERNELS_LOOP
);
686 matcha ("end kernels", gfc_match_omp_eos_error
, ST_OACC_END_KERNELS
);
687 matcha ("end loop", gfc_match_omp_eos_error
, ST_OACC_END_LOOP
);
688 matcha ("end parallel loop", gfc_match_omp_eos_error
,
689 ST_OACC_END_PARALLEL_LOOP
);
690 matcha ("end parallel", gfc_match_omp_eos_error
, ST_OACC_END_PARALLEL
);
691 matcha ("end serial loop", gfc_match_omp_eos_error
,
692 ST_OACC_END_SERIAL_LOOP
);
693 matcha ("end serial", gfc_match_omp_eos_error
, ST_OACC_END_SERIAL
);
694 matcha ("enter data", gfc_match_oacc_enter_data
, ST_OACC_ENTER_DATA
);
695 matcha ("exit data", gfc_match_oacc_exit_data
, ST_OACC_EXIT_DATA
);
698 matcha ("host_data", gfc_match_oacc_host_data
, ST_OACC_HOST_DATA
);
701 matcha ("parallel loop", gfc_match_oacc_parallel_loop
,
702 ST_OACC_PARALLEL_LOOP
);
703 matcha ("parallel", gfc_match_oacc_parallel
, ST_OACC_PARALLEL
);
706 matcha ("kernels loop", gfc_match_oacc_kernels_loop
,
707 ST_OACC_KERNELS_LOOP
);
708 matcha ("kernels", gfc_match_oacc_kernels
, ST_OACC_KERNELS
);
711 matcha ("loop", gfc_match_oacc_loop
, ST_OACC_LOOP
);
714 matcha ("serial loop", gfc_match_oacc_serial_loop
, ST_OACC_SERIAL_LOOP
);
715 matcha ("serial", gfc_match_oacc_serial
, ST_OACC_SERIAL
);
718 matcha ("update", gfc_match_oacc_update
, ST_OACC_UPDATE
);
721 matcha ("wait", gfc_match_oacc_wait
, ST_OACC_WAIT
);
725 /* Directive not found or stored an error message.
726 Check and give up. */
729 if (gfc_error_check () == 0)
730 gfc_error_now ("Unclassifiable OpenACC directive at %C");
734 gfc_error_recovery ();
741 gfc_buffer_error (false);
742 gfc_current_locus
= old_locus
;
743 return ST_GET_FCN_CHARACTERISTICS
;
746 /* Like match, but set a flag simd_matched if keyword matched
747 and if spec_only, goto do_spec_only without actually matching. */
748 #define matchs(keyword, subr, st) \
751 if (spec_only && gfc_match (keyword) == MATCH_YES) \
753 if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \
754 &simd_matched)) == MATCH_YES) \
759 else if (m2 == MATCH_ERROR) \
760 goto error_handling; \
762 undo_new_statement (); \
765 /* Like match, but don't match anything if not -fopenmp
766 and if spec_only, goto do_spec_only without actually matching. */
767 /* If the directive matched but the clauses failed, do not start
768 matching the next directive in the same switch statement. */
769 #define matcho(keyword, subr, st) \
774 else if (spec_only && gfc_match (keyword) == MATCH_YES) \
776 else if ((m2 = match_word (keyword, subr, &old_locus)) \
782 else if (m2 == MATCH_ERROR) \
783 goto error_handling; \
785 undo_new_statement (); \
788 /* Like match, but set a flag simd_matched if keyword matched. */
789 #define matchds(keyword, subr, st) \
792 if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \
793 &simd_matched)) == MATCH_YES) \
798 else if (m2 == MATCH_ERROR) \
799 goto error_handling; \
801 undo_new_statement (); \
804 /* Like match, but don't match anything if not -fopenmp. */
805 #define matchdo(keyword, subr, st) \
810 else if ((m2 = match_word (keyword, subr, &old_locus)) \
816 else if (m2 == MATCH_ERROR) \
817 goto error_handling; \
819 undo_new_statement (); \
823 decode_omp_directive (void)
827 bool simd_matched
= false;
828 bool spec_only
= false;
829 gfc_statement ret
= ST_NONE
;
832 gfc_enforce_clean_symbol_state ();
834 gfc_clear_error (); /* Clear any pending errors. */
835 gfc_clear_warning (); /* Clear any pending warnings. */
837 gfc_matching_function
= false;
839 if (gfc_current_state () == COMP_FUNCTION
840 && gfc_current_block ()->result
->ts
.kind
== -1)
843 old_locus
= gfc_current_locus
;
845 /* General OpenMP directive matching: Instead of testing every possible
846 statement, we eliminate most possibilities by peeking at the
849 c
= gfc_peek_ascii_char ();
851 /* match is for directives that should be recognized only if
852 -fopenmp, matchs for directives that should be recognized
853 if either -fopenmp or -fopenmp-simd.
854 Handle only the directives allowed in PURE procedures
855 first (those also shall not turn off implicit pure). */
859 matchds ("declare simd", gfc_match_omp_declare_simd
,
860 ST_OMP_DECLARE_SIMD
);
861 matchdo ("declare target", gfc_match_omp_declare_target
,
862 ST_OMP_DECLARE_TARGET
);
865 matchs ("simd", gfc_match_omp_simd
, ST_OMP_SIMD
);
870 if (flag_openmp
&& gfc_pure (NULL
))
872 gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET "
873 "at %C may not appear in PURE procedures");
874 gfc_error_recovery ();
878 /* match is for directives that should be recognized only if
879 -fopenmp, matchs for directives that should be recognized
880 if either -fopenmp or -fopenmp-simd. */
884 matcho ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
887 matcho ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
890 matcho ("cancellation% point", gfc_match_omp_cancellation_point
,
891 ST_OMP_CANCELLATION_POINT
);
892 matcho ("cancel", gfc_match_omp_cancel
, ST_OMP_CANCEL
);
893 matcho ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
896 matchds ("declare reduction", gfc_match_omp_declare_reduction
,
897 ST_OMP_DECLARE_REDUCTION
);
898 matchs ("distribute parallel do simd",
899 gfc_match_omp_distribute_parallel_do_simd
,
900 ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
);
901 matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do
,
902 ST_OMP_DISTRIBUTE_PARALLEL_DO
);
903 matchs ("distribute simd", gfc_match_omp_distribute_simd
,
904 ST_OMP_DISTRIBUTE_SIMD
);
905 matcho ("distribute", gfc_match_omp_distribute
, ST_OMP_DISTRIBUTE
);
906 matchs ("do simd", gfc_match_omp_do_simd
, ST_OMP_DO_SIMD
);
907 matcho ("do", gfc_match_omp_do
, ST_OMP_DO
);
910 matcho ("end atomic", gfc_match_omp_eos_error
, ST_OMP_END_ATOMIC
);
911 matcho ("end critical", gfc_match_omp_end_critical
, ST_OMP_END_CRITICAL
);
912 matchs ("end distribute parallel do simd", gfc_match_omp_eos_error
,
913 ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
);
914 matcho ("end distribute parallel do", gfc_match_omp_eos_error
,
915 ST_OMP_END_DISTRIBUTE_PARALLEL_DO
);
916 matchs ("end distribute simd", gfc_match_omp_eos_error
,
917 ST_OMP_END_DISTRIBUTE_SIMD
);
918 matcho ("end distribute", gfc_match_omp_eos_error
, ST_OMP_END_DISTRIBUTE
);
919 matchs ("end do simd", gfc_match_omp_end_nowait
, ST_OMP_END_DO_SIMD
);
920 matcho ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
921 matchs ("end simd", gfc_match_omp_eos_error
, ST_OMP_END_SIMD
);
922 matcho ("end master", gfc_match_omp_eos_error
, ST_OMP_END_MASTER
);
923 matchs ("end ordered", gfc_match_omp_eos_error
, ST_OMP_END_ORDERED
);
924 matchs ("end parallel do simd", gfc_match_omp_eos_error
,
925 ST_OMP_END_PARALLEL_DO_SIMD
);
926 matcho ("end parallel do", gfc_match_omp_eos_error
, ST_OMP_END_PARALLEL_DO
);
927 matcho ("end parallel sections", gfc_match_omp_eos_error
,
928 ST_OMP_END_PARALLEL_SECTIONS
);
929 matcho ("end parallel workshare", gfc_match_omp_eos_error
,
930 ST_OMP_END_PARALLEL_WORKSHARE
);
931 matcho ("end parallel", gfc_match_omp_eos_error
, ST_OMP_END_PARALLEL
);
932 matcho ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
933 matcho ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
934 matcho ("end target data", gfc_match_omp_eos_error
, ST_OMP_END_TARGET_DATA
);
935 matchs ("end target parallel do simd", gfc_match_omp_eos_error
,
936 ST_OMP_END_TARGET_PARALLEL_DO_SIMD
);
937 matcho ("end target parallel do", gfc_match_omp_eos_error
,
938 ST_OMP_END_TARGET_PARALLEL_DO
);
939 matcho ("end target parallel", gfc_match_omp_eos_error
,
940 ST_OMP_END_TARGET_PARALLEL
);
941 matchs ("end target simd", gfc_match_omp_eos_error
, ST_OMP_END_TARGET_SIMD
);
942 matchs ("end target teams distribute parallel do simd",
943 gfc_match_omp_eos_error
,
944 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
945 matcho ("end target teams distribute parallel do", gfc_match_omp_eos_error
,
946 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
947 matchs ("end target teams distribute simd", gfc_match_omp_eos_error
,
948 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
);
949 matcho ("end target teams distribute", gfc_match_omp_eos_error
,
950 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
);
951 matcho ("end target teams", gfc_match_omp_eos_error
, ST_OMP_END_TARGET_TEAMS
);
952 matcho ("end target", gfc_match_omp_eos_error
, ST_OMP_END_TARGET
);
953 matcho ("end taskgroup", gfc_match_omp_eos_error
, ST_OMP_END_TASKGROUP
);
954 matchs ("end taskloop simd", gfc_match_omp_eos_error
,
955 ST_OMP_END_TASKLOOP_SIMD
);
956 matcho ("end taskloop", gfc_match_omp_eos_error
, ST_OMP_END_TASKLOOP
);
957 matcho ("end task", gfc_match_omp_eos_error
, ST_OMP_END_TASK
);
958 matchs ("end teams distribute parallel do simd", gfc_match_omp_eos_error
,
959 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
960 matcho ("end teams distribute parallel do", gfc_match_omp_eos_error
,
961 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
);
962 matchs ("end teams distribute simd", gfc_match_omp_eos_error
,
963 ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
);
964 matcho ("end teams distribute", gfc_match_omp_eos_error
,
965 ST_OMP_END_TEAMS_DISTRIBUTE
);
966 matcho ("end teams", gfc_match_omp_eos_error
, ST_OMP_END_TEAMS
);
967 matcho ("end workshare", gfc_match_omp_end_nowait
,
968 ST_OMP_END_WORKSHARE
);
971 matcho ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
974 matcho ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
977 if (gfc_match ("ordered depend (") == MATCH_YES
)
979 gfc_current_locus
= old_locus
;
982 matcho ("ordered", gfc_match_omp_ordered_depend
,
983 ST_OMP_ORDERED_DEPEND
);
986 matchs ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
989 matchs ("parallel do simd", gfc_match_omp_parallel_do_simd
,
990 ST_OMP_PARALLEL_DO_SIMD
);
991 matcho ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
992 matcho ("parallel sections", gfc_match_omp_parallel_sections
,
993 ST_OMP_PARALLEL_SECTIONS
);
994 matcho ("parallel workshare", gfc_match_omp_parallel_workshare
,
995 ST_OMP_PARALLEL_WORKSHARE
);
996 matcho ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
999 matcho ("requires", gfc_match_omp_requires
, ST_OMP_REQUIRES
);
1002 matcho ("scan", gfc_match_omp_scan
, ST_OMP_SCAN
);
1003 matcho ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
1004 matcho ("section", gfc_match_omp_eos_error
, ST_OMP_SECTION
);
1005 matcho ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
1008 matcho ("target data", gfc_match_omp_target_data
, ST_OMP_TARGET_DATA
);
1009 matcho ("target enter data", gfc_match_omp_target_enter_data
,
1010 ST_OMP_TARGET_ENTER_DATA
);
1011 matcho ("target exit data", gfc_match_omp_target_exit_data
,
1012 ST_OMP_TARGET_EXIT_DATA
);
1013 matchs ("target parallel do simd", gfc_match_omp_target_parallel_do_simd
,
1014 ST_OMP_TARGET_PARALLEL_DO_SIMD
);
1015 matcho ("target parallel do", gfc_match_omp_target_parallel_do
,
1016 ST_OMP_TARGET_PARALLEL_DO
);
1017 matcho ("target parallel", gfc_match_omp_target_parallel
,
1018 ST_OMP_TARGET_PARALLEL
);
1019 matchs ("target simd", gfc_match_omp_target_simd
, ST_OMP_TARGET_SIMD
);
1020 matchs ("target teams distribute parallel do simd",
1021 gfc_match_omp_target_teams_distribute_parallel_do_simd
,
1022 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
1023 matcho ("target teams distribute parallel do",
1024 gfc_match_omp_target_teams_distribute_parallel_do
,
1025 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
1026 matchs ("target teams distribute simd",
1027 gfc_match_omp_target_teams_distribute_simd
,
1028 ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
);
1029 matcho ("target teams distribute", gfc_match_omp_target_teams_distribute
,
1030 ST_OMP_TARGET_TEAMS_DISTRIBUTE
);
1031 matcho ("target teams", gfc_match_omp_target_teams
, ST_OMP_TARGET_TEAMS
);
1032 matcho ("target update", gfc_match_omp_target_update
,
1033 ST_OMP_TARGET_UPDATE
);
1034 matcho ("target", gfc_match_omp_target
, ST_OMP_TARGET
);
1035 matcho ("taskgroup", gfc_match_omp_taskgroup
, ST_OMP_TASKGROUP
);
1036 matchs ("taskloop simd", gfc_match_omp_taskloop_simd
,
1037 ST_OMP_TASKLOOP_SIMD
);
1038 matcho ("taskloop", gfc_match_omp_taskloop
, ST_OMP_TASKLOOP
);
1039 matcho ("taskwait", gfc_match_omp_taskwait
, ST_OMP_TASKWAIT
);
1040 matcho ("taskyield", gfc_match_omp_taskyield
, ST_OMP_TASKYIELD
);
1041 matcho ("task", gfc_match_omp_task
, ST_OMP_TASK
);
1042 matchs ("teams distribute parallel do simd",
1043 gfc_match_omp_teams_distribute_parallel_do_simd
,
1044 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
1045 matcho ("teams distribute parallel do",
1046 gfc_match_omp_teams_distribute_parallel_do
,
1047 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
);
1048 matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd
,
1049 ST_OMP_TEAMS_DISTRIBUTE_SIMD
);
1050 matcho ("teams distribute", gfc_match_omp_teams_distribute
,
1051 ST_OMP_TEAMS_DISTRIBUTE
);
1052 matcho ("teams", gfc_match_omp_teams
, ST_OMP_TEAMS
);
1053 matchdo ("threadprivate", gfc_match_omp_threadprivate
,
1054 ST_OMP_THREADPRIVATE
);
1057 matcho ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
1061 /* All else has failed, so give up. See if any of the matchers has
1062 stored an error message of some sort. Don't error out if
1063 not -fopenmp and simd_matched is false, i.e. if a directive other
1064 than one marked with match has been seen. */
1067 if (flag_openmp
|| simd_matched
)
1069 if (!gfc_error_check ())
1070 gfc_error_now ("Unclassifiable OpenMP directive at %C");
1073 reject_statement ();
1075 gfc_error_recovery ();
1082 gfc_unset_implicit_pure (NULL
);
1084 if (!flag_openmp
&& gfc_pure (NULL
))
1086 gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET "
1087 "at %C may not appear in PURE procedures");
1088 reject_statement ();
1089 gfc_error_recovery ();
1095 case ST_OMP_DECLARE_TARGET
:
1097 case ST_OMP_TARGET_DATA
:
1098 case ST_OMP_TARGET_ENTER_DATA
:
1099 case ST_OMP_TARGET_EXIT_DATA
:
1100 case ST_OMP_TARGET_TEAMS
:
1101 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
1102 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
1103 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1104 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1105 case ST_OMP_TARGET_PARALLEL
:
1106 case ST_OMP_TARGET_PARALLEL_DO
:
1107 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
1108 case ST_OMP_TARGET_SIMD
:
1109 case ST_OMP_TARGET_UPDATE
:
1111 gfc_namespace
*prog_unit
= gfc_current_ns
;
1112 while (prog_unit
->parent
)
1114 if (gfc_state_stack
->previous
1115 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
1117 prog_unit
= prog_unit
->parent
;
1119 prog_unit
->omp_target_seen
= true;
1128 reject_statement ();
1130 gfc_buffer_error (false);
1131 gfc_current_locus
= old_locus
;
1132 return ST_GET_FCN_CHARACTERISTICS
;
1135 static gfc_statement
1136 decode_gcc_attribute (void)
1140 gfc_enforce_clean_symbol_state ();
1142 gfc_clear_error (); /* Clear any pending errors. */
1143 gfc_clear_warning (); /* Clear any pending warnings. */
1144 old_locus
= gfc_current_locus
;
1146 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
1147 match ("unroll", gfc_match_gcc_unroll
, ST_NONE
);
1148 match ("builtin", gfc_match_gcc_builtin
, ST_NONE
);
1149 match ("ivdep", gfc_match_gcc_ivdep
, ST_NONE
);
1150 match ("vector", gfc_match_gcc_vector
, ST_NONE
);
1151 match ("novector", gfc_match_gcc_novector
, ST_NONE
);
1153 /* All else has failed, so give up. See if any of the matchers has
1154 stored an error message of some sort. */
1156 if (!gfc_error_check ())
1159 gfc_error_now ("Unclassifiable GCC directive at %C");
1161 gfc_warning_now (0, "Unclassifiable GCC directive at %C, ignored");
1164 reject_statement ();
1166 gfc_error_recovery ();
1173 /* Assert next length characters to be equal to token in free form. */
1176 verify_token_free (const char* token
, int length
, bool last_was_use_stmt
)
1181 c
= gfc_next_ascii_char ();
1182 for (i
= 0; i
< length
; i
++, c
= gfc_next_ascii_char ())
1183 gcc_assert (c
== token
[i
]);
1185 gcc_assert (gfc_is_whitespace(c
));
1186 gfc_gobble_whitespace ();
1187 if (last_was_use_stmt
)
1191 /* Get the next statement in free form source. */
1193 static gfc_statement
1200 at_bol
= gfc_at_bol ();
1201 gfc_gobble_whitespace ();
1203 c
= gfc_peek_ascii_char ();
1209 /* Found a statement label? */
1210 m
= gfc_match_st_label (&gfc_statement_label
);
1212 d
= gfc_peek_ascii_char ();
1213 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
1215 gfc_match_small_literal_int (&i
, &cnt
);
1218 gfc_error_now ("Too many digits in statement label at %C");
1221 gfc_error_now ("Zero is not a valid statement label at %C");
1224 c
= gfc_next_ascii_char ();
1227 if (!gfc_is_whitespace (c
))
1228 gfc_error_now ("Non-numeric character in statement label at %C");
1234 label_locus
= gfc_current_locus
;
1236 gfc_gobble_whitespace ();
1238 if (at_bol
&& gfc_peek_ascii_char () == ';')
1240 gfc_error_now ("Semicolon at %C needs to be preceded by "
1242 gfc_next_ascii_char (); /* Eat up the semicolon. */
1246 if (gfc_match_eos () == MATCH_YES
)
1247 gfc_error_now ("Statement label without statement at %L",
1253 /* Comments have already been skipped by the time we get here,
1254 except for GCC attributes and OpenMP/OpenACC directives. */
1256 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
1257 c
= gfc_peek_ascii_char ();
1263 c
= gfc_next_ascii_char ();
1264 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
1265 gcc_assert (c
== "gcc$"[i
]);
1267 gfc_gobble_whitespace ();
1268 return decode_gcc_attribute ();
1273 /* Since both OpenMP and OpenACC directives starts with
1274 !$ character sequence, we must check all flags combinations */
1275 if ((flag_openmp
|| flag_openmp_simd
)
1278 verify_token_free ("$omp", 4, last_was_use_stmt
);
1279 return decode_omp_directive ();
1281 else if ((flag_openmp
|| flag_openmp_simd
)
1284 gfc_next_ascii_char (); /* Eat up dollar character */
1285 c
= gfc_peek_ascii_char ();
1289 verify_token_free ("omp", 3, last_was_use_stmt
);
1290 return decode_omp_directive ();
1294 verify_token_free ("acc", 3, last_was_use_stmt
);
1295 return decode_oacc_directive ();
1298 else if (flag_openacc
)
1300 verify_token_free ("$acc", 4, last_was_use_stmt
);
1301 return decode_oacc_directive ();
1307 if (at_bol
&& c
== ';')
1309 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1310 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1312 gfc_next_ascii_char (); /* Eat up the semicolon. */
1316 return decode_statement ();
1319 /* Assert next length characters to be equal to token in fixed form. */
1322 verify_token_fixed (const char *token
, int length
, bool last_was_use_stmt
)
1325 char c
= gfc_next_char_literal (NONSTRING
);
1327 for (i
= 0; i
< length
; i
++, c
= gfc_next_char_literal (NONSTRING
))
1328 gcc_assert ((char) gfc_wide_tolower (c
) == token
[i
]);
1330 if (c
!= ' ' && c
!= '0')
1332 gfc_buffer_error (false);
1333 gfc_error ("Bad continuation line at %C");
1336 if (last_was_use_stmt
)
1342 /* Get the next statement in fixed-form source. */
1344 static gfc_statement
1347 int label
, digit_flag
, i
;
1352 return decode_statement ();
1354 /* Skip past the current label field, parsing a statement label if
1355 one is there. This is a weird number parser, since the number is
1356 contained within five columns and can have any kind of embedded
1357 spaces. We also check for characters that make the rest of the
1363 for (i
= 0; i
< 5; i
++)
1365 c
= gfc_next_char_literal (NONSTRING
);
1382 label
= label
* 10 + ((unsigned char) c
- '0');
1383 label_locus
= gfc_current_locus
;
1387 /* Comments have already been skipped by the time we get
1388 here, except for GCC attributes and OpenMP directives. */
1391 c
= gfc_next_char_literal (NONSTRING
);
1393 if (TOLOWER (c
) == 'g')
1395 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
1396 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
1398 return decode_gcc_attribute ();
1402 if ((flag_openmp
|| flag_openmp_simd
)
1405 if (!verify_token_fixed ("omp", 3, last_was_use_stmt
))
1407 return decode_omp_directive ();
1409 else if ((flag_openmp
|| flag_openmp_simd
)
1412 c
= gfc_next_char_literal(NONSTRING
);
1413 if (c
== 'o' || c
== 'O')
1415 if (!verify_token_fixed ("mp", 2, last_was_use_stmt
))
1417 return decode_omp_directive ();
1419 else if (c
== 'a' || c
== 'A')
1421 if (!verify_token_fixed ("cc", 2, last_was_use_stmt
))
1423 return decode_oacc_directive ();
1426 else if (flag_openacc
)
1428 if (!verify_token_fixed ("acc", 3, last_was_use_stmt
))
1430 return decode_oacc_directive ();
1435 /* Comments have already been skipped by the time we get
1436 here so don't bother checking for them. */
1439 gfc_buffer_error (false);
1440 gfc_error ("Non-numeric character in statement label at %C");
1448 gfc_warning_now (0, "Zero is not a valid statement label at %C");
1451 /* We've found a valid statement label. */
1452 gfc_statement_label
= gfc_get_st_label (label
);
1456 /* Since this line starts a statement, it cannot be a continuation
1457 of a previous statement. If we see something here besides a
1458 space or zero, it must be a bad continuation line. */
1460 c
= gfc_next_char_literal (NONSTRING
);
1464 if (c
!= ' ' && c
!= '0')
1466 gfc_buffer_error (false);
1467 gfc_error ("Bad continuation line at %C");
1471 /* Now that we've taken care of the statement label columns, we have
1472 to make sure that the first nonblank character is not a '!'. If
1473 it is, the rest of the line is a comment. */
1477 loc
= gfc_current_locus
;
1478 c
= gfc_next_char_literal (NONSTRING
);
1480 while (gfc_is_whitespace (c
));
1484 gfc_current_locus
= loc
;
1489 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1490 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1491 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1496 if (gfc_match_eos () == MATCH_YES
)
1499 /* At this point, we've got a nonblank statement to parse. */
1500 return decode_statement ();
1504 gfc_error_now ("Statement label without statement at %L", &label_locus
);
1506 gfc_current_locus
.lb
->truncated
= 0;
1507 gfc_advance_line ();
1512 /* Return the next non-ST_NONE statement to the caller. We also worry
1513 about including files and the ends of include files at this stage. */
1515 static gfc_statement
1516 next_statement (void)
1521 gfc_enforce_clean_symbol_state ();
1523 gfc_new_block
= NULL
;
1525 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1526 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
1529 gfc_statement_label
= NULL
;
1530 gfc_buffer_error (true);
1533 gfc_advance_line ();
1535 gfc_skip_comments ();
1543 if (gfc_define_undef_line ())
1546 old_locus
= gfc_current_locus
;
1548 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1554 gfc_buffer_error (false);
1556 if (st
== ST_GET_FCN_CHARACTERISTICS
)
1558 if (gfc_statement_label
!= NULL
)
1560 gfc_free_st_label (gfc_statement_label
);
1561 gfc_statement_label
= NULL
;
1563 gfc_current_locus
= old_locus
;
1567 check_statement_label (st
);
1573 /****************************** Parser ***********************************/
1575 /* The parser subroutines are of type 'try' that fail if the file ends
1578 /* Macros that expand to case-labels for various classes of
1579 statements. Start with executable statements that directly do
1582 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1583 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1584 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1585 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1586 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1587 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1588 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1589 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1590 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1591 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
1592 case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
1593 case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: \
1594 case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \
1595 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1596 case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
1597 case ST_END_TEAM: case ST_SYNC_TEAM: \
1598 case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
1599 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1600 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1602 /* Statements that mark other executable statements. */
1604 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1605 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1606 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1607 case ST_SELECT_RANK: case ST_OMP_PARALLEL: \
1608 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1609 case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
1610 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1611 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1612 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1613 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1614 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1615 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1616 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1617 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1618 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1619 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1620 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1621 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1622 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1623 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1624 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \
1625 case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \
1626 case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
1628 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1629 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
1630 case ST_OACC_KERNELS_LOOP: case ST_OACC_SERIAL_LOOP: case ST_OACC_SERIAL: \
1633 /* Declaration statements */
1635 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1636 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1637 case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE
1639 /* OpenMP and OpenACC declaration statements, which may appear anywhere in
1640 the specification part. */
1642 #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
1643 case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \
1644 case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
1647 /* Block end statements. Errors associated with interchanging these
1648 are detected in gfc_match_end(). */
1650 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1651 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1652 case ST_END_BLOCK: case ST_END_ASSOCIATE
1655 /* Push a new state onto the stack. */
1658 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1660 p
->state
= new_state
;
1661 p
->previous
= gfc_state_stack
;
1663 p
->head
= p
->tail
= NULL
;
1664 p
->do_variable
= NULL
;
1665 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1666 p
->ext
.oacc_declare_clauses
= NULL
;
1668 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1669 construct statement was accepted right before pushing the state. Thus,
1670 the construct's gfc_code is available as tail of the parent state. */
1671 gcc_assert (gfc_state_stack
);
1672 p
->construct
= gfc_state_stack
->tail
;
1674 gfc_state_stack
= p
;
1678 /* Pop the current state. */
1682 gfc_state_stack
= gfc_state_stack
->previous
;
1686 /* Try to find the given state in the state stack. */
1689 gfc_find_state (gfc_compile_state state
)
1693 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1694 if (p
->state
== state
)
1697 return (p
== NULL
) ? false : true;
1701 /* Starts a new level in the statement list. */
1704 new_level (gfc_code
*q
)
1708 p
= q
->block
= gfc_get_code (EXEC_NOP
);
1710 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
1716 /* Add the current new_st code structure and adds it to the current
1717 program unit. As a side-effect, it zeroes the new_st. */
1720 add_statement (void)
1724 p
= XCNEW (gfc_code
);
1727 p
->loc
= gfc_current_locus
;
1729 if (gfc_state_stack
->head
== NULL
)
1730 gfc_state_stack
->head
= p
;
1732 gfc_state_stack
->tail
->next
= p
;
1734 while (p
->next
!= NULL
)
1737 gfc_state_stack
->tail
= p
;
1739 gfc_clear_new_st ();
1745 /* Frees everything associated with the current statement. */
1748 undo_new_statement (void)
1750 gfc_free_statements (new_st
.block
);
1751 gfc_free_statements (new_st
.next
);
1752 gfc_free_statement (&new_st
);
1753 gfc_clear_new_st ();
1757 /* If the current statement has a statement label, make sure that it
1758 is allowed to, or should have one. */
1761 check_statement_label (gfc_statement st
)
1765 if (gfc_statement_label
== NULL
)
1767 if (st
== ST_FORMAT
)
1768 gfc_error ("FORMAT statement at %L does not have a statement label",
1775 case ST_END_PROGRAM
:
1776 case ST_END_FUNCTION
:
1777 case ST_END_SUBROUTINE
:
1781 case ST_END_CRITICAL
:
1783 case ST_END_ASSOCIATE
:
1786 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
1787 type
= ST_LABEL_DO_TARGET
;
1789 type
= ST_LABEL_TARGET
;
1793 type
= ST_LABEL_FORMAT
;
1796 /* Statement labels are not restricted from appearing on a
1797 particular line. However, there are plenty of situations
1798 where the resulting label can't be referenced. */
1801 type
= ST_LABEL_BAD_TARGET
;
1805 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
1807 new_st
.here
= gfc_statement_label
;
1811 /* Figures out what the enclosing program unit is. This will be a
1812 function, subroutine, program, block data or module. */
1815 gfc_enclosing_unit (gfc_compile_state
* result
)
1819 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1820 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
1821 || p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
1822 || p
->state
== COMP_BLOCK_DATA
|| p
->state
== COMP_PROGRAM
)
1831 *result
= COMP_PROGRAM
;
1836 /* Translate a statement enum to a string. */
1839 gfc_ascii_statement (gfc_statement st
)
1845 case ST_ARITHMETIC_IF
:
1846 p
= _("arithmetic IF");
1855 p
= _("attribute declaration");
1891 p
= _("data declaration");
1905 case ST_STRUCTURE_DECL
:
1908 case ST_DERIVED_DECL
:
1909 p
= _("derived type declaration");
1932 case ST_CHANGE_TEAM
:
1944 case ST_END_ASSOCIATE
:
1945 p
= "END ASSOCIATE";
1950 case ST_END_BLOCK_DATA
:
1951 p
= "END BLOCK DATA";
1953 case ST_END_CRITICAL
:
1965 case ST_END_FUNCTION
:
1971 case ST_END_INTERFACE
:
1972 p
= "END INTERFACE";
1977 case ST_END_SUBMODULE
:
1978 p
= "END SUBMODULE";
1980 case ST_END_PROGRAM
:
1986 case ST_END_SUBROUTINE
:
1987 p
= "END SUBROUTINE";
1992 case ST_END_STRUCTURE
:
1993 p
= "END STRUCTURE";
2007 case ST_EQUIVALENCE
:
2019 case ST_FORALL_BLOCK
: /* Fall through */
2041 case ST_IMPLICIT_NONE
:
2042 p
= "IMPLICIT NONE";
2044 case ST_IMPLIED_ENDDO
:
2045 p
= _("implied END DO");
2077 case ST_MODULE_PROC
:
2078 p
= "MODULE PROCEDURE";
2110 case ST_SYNC_IMAGES
:
2113 case ST_SYNC_MEMORY
:
2128 case ST_WHERE_BLOCK
: /* Fall through */
2139 p
= _("assignment");
2141 case ST_POINTER_ASSIGNMENT
:
2142 p
= _("pointer assignment");
2144 case ST_SELECT_CASE
:
2147 case ST_SELECT_TYPE
:
2150 case ST_SELECT_RANK
:
2168 case ST_STATEMENT_FUNCTION
:
2169 p
= "STATEMENT FUNCTION";
2171 case ST_LABEL_ASSIGNMENT
:
2172 p
= "LABEL ASSIGNMENT";
2175 p
= "ENUM DEFINITION";
2178 p
= "ENUMERATOR DEFINITION";
2183 case ST_OACC_PARALLEL_LOOP
:
2184 p
= "!$ACC PARALLEL LOOP";
2186 case ST_OACC_END_PARALLEL_LOOP
:
2187 p
= "!$ACC END PARALLEL LOOP";
2189 case ST_OACC_PARALLEL
:
2190 p
= "!$ACC PARALLEL";
2192 case ST_OACC_END_PARALLEL
:
2193 p
= "!$ACC END PARALLEL";
2195 case ST_OACC_KERNELS
:
2196 p
= "!$ACC KERNELS";
2198 case ST_OACC_END_KERNELS
:
2199 p
= "!$ACC END KERNELS";
2201 case ST_OACC_KERNELS_LOOP
:
2202 p
= "!$ACC KERNELS LOOP";
2204 case ST_OACC_END_KERNELS_LOOP
:
2205 p
= "!$ACC END KERNELS LOOP";
2207 case ST_OACC_SERIAL_LOOP
:
2208 p
= "!$ACC SERIAL LOOP";
2210 case ST_OACC_END_SERIAL_LOOP
:
2211 p
= "!$ACC END SERIAL LOOP";
2213 case ST_OACC_SERIAL
:
2216 case ST_OACC_END_SERIAL
:
2217 p
= "!$ACC END SERIAL";
2222 case ST_OACC_END_DATA
:
2223 p
= "!$ACC END DATA";
2225 case ST_OACC_HOST_DATA
:
2226 p
= "!$ACC HOST_DATA";
2228 case ST_OACC_END_HOST_DATA
:
2229 p
= "!$ACC END HOST_DATA";
2234 case ST_OACC_END_LOOP
:
2235 p
= "!$ACC END LOOP";
2237 case ST_OACC_DECLARE
:
2238 p
= "!$ACC DECLARE";
2240 case ST_OACC_UPDATE
:
2249 case ST_OACC_ENTER_DATA
:
2250 p
= "!$ACC ENTER DATA";
2252 case ST_OACC_EXIT_DATA
:
2253 p
= "!$ACC EXIT DATA";
2255 case ST_OACC_ROUTINE
:
2256 p
= "!$ACC ROUTINE";
2258 case ST_OACC_ATOMIC
:
2261 case ST_OACC_END_ATOMIC
:
2262 p
= "!$ACC END ATOMIC";
2267 case ST_OMP_BARRIER
:
2268 p
= "!$OMP BARRIER";
2273 case ST_OMP_CANCELLATION_POINT
:
2274 p
= "!$OMP CANCELLATION POINT";
2276 case ST_OMP_CRITICAL
:
2277 p
= "!$OMP CRITICAL";
2279 case ST_OMP_DECLARE_REDUCTION
:
2280 p
= "!$OMP DECLARE REDUCTION";
2282 case ST_OMP_DECLARE_SIMD
:
2283 p
= "!$OMP DECLARE SIMD";
2285 case ST_OMP_DECLARE_TARGET
:
2286 p
= "!$OMP DECLARE TARGET";
2288 case ST_OMP_DISTRIBUTE
:
2289 p
= "!$OMP DISTRIBUTE";
2291 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
2292 p
= "!$OMP DISTRIBUTE PARALLEL DO";
2294 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2295 p
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
2297 case ST_OMP_DISTRIBUTE_SIMD
:
2298 p
= "!$OMP DISTRIBUTE SIMD";
2303 case ST_OMP_DO_SIMD
:
2304 p
= "!$OMP DO SIMD";
2306 case ST_OMP_END_ATOMIC
:
2307 p
= "!$OMP END ATOMIC";
2309 case ST_OMP_END_CRITICAL
:
2310 p
= "!$OMP END CRITICAL";
2312 case ST_OMP_END_DISTRIBUTE
:
2313 p
= "!$OMP END DISTRIBUTE";
2315 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO
:
2316 p
= "!$OMP END DISTRIBUTE PARALLEL DO";
2318 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
:
2319 p
= "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
2321 case ST_OMP_END_DISTRIBUTE_SIMD
:
2322 p
= "!$OMP END DISTRIBUTE SIMD";
2327 case ST_OMP_END_DO_SIMD
:
2328 p
= "!$OMP END DO SIMD";
2330 case ST_OMP_END_SIMD
:
2331 p
= "!$OMP END SIMD";
2333 case ST_OMP_END_MASTER
:
2334 p
= "!$OMP END MASTER";
2336 case ST_OMP_END_ORDERED
:
2337 p
= "!$OMP END ORDERED";
2339 case ST_OMP_END_PARALLEL
:
2340 p
= "!$OMP END PARALLEL";
2342 case ST_OMP_END_PARALLEL_DO
:
2343 p
= "!$OMP END PARALLEL DO";
2345 case ST_OMP_END_PARALLEL_DO_SIMD
:
2346 p
= "!$OMP END PARALLEL DO SIMD";
2348 case ST_OMP_END_PARALLEL_SECTIONS
:
2349 p
= "!$OMP END PARALLEL SECTIONS";
2351 case ST_OMP_END_PARALLEL_WORKSHARE
:
2352 p
= "!$OMP END PARALLEL WORKSHARE";
2354 case ST_OMP_END_SECTIONS
:
2355 p
= "!$OMP END SECTIONS";
2357 case ST_OMP_END_SINGLE
:
2358 p
= "!$OMP END SINGLE";
2360 case ST_OMP_END_TASK
:
2361 p
= "!$OMP END TASK";
2363 case ST_OMP_END_TARGET
:
2364 p
= "!$OMP END TARGET";
2366 case ST_OMP_END_TARGET_DATA
:
2367 p
= "!$OMP END TARGET DATA";
2369 case ST_OMP_END_TARGET_PARALLEL
:
2370 p
= "!$OMP END TARGET PARALLEL";
2372 case ST_OMP_END_TARGET_PARALLEL_DO
:
2373 p
= "!$OMP END TARGET PARALLEL DO";
2375 case ST_OMP_END_TARGET_PARALLEL_DO_SIMD
:
2376 p
= "!$OMP END TARGET PARALLEL DO SIMD";
2378 case ST_OMP_END_TARGET_SIMD
:
2379 p
= "!$OMP END TARGET SIMD";
2381 case ST_OMP_END_TARGET_TEAMS
:
2382 p
= "!$OMP END TARGET TEAMS";
2384 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
:
2385 p
= "!$OMP END TARGET TEAMS DISTRIBUTE";
2387 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2388 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2390 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2391 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2393 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2394 p
= "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2396 case ST_OMP_END_TASKGROUP
:
2397 p
= "!$OMP END TASKGROUP";
2399 case ST_OMP_END_TASKLOOP
:
2400 p
= "!$OMP END TASKLOOP";
2402 case ST_OMP_END_TASKLOOP_SIMD
:
2403 p
= "!$OMP END TASKLOOP SIMD";
2405 case ST_OMP_END_TEAMS
:
2406 p
= "!$OMP END TEAMS";
2408 case ST_OMP_END_TEAMS_DISTRIBUTE
:
2409 p
= "!$OMP END TEAMS DISTRIBUTE";
2411 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2412 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2414 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2415 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2417 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
:
2418 p
= "!$OMP END TEAMS DISTRIBUTE SIMD";
2420 case ST_OMP_END_WORKSHARE
:
2421 p
= "!$OMP END WORKSHARE";
2429 case ST_OMP_ORDERED
:
2430 case ST_OMP_ORDERED_DEPEND
:
2431 p
= "!$OMP ORDERED";
2433 case ST_OMP_PARALLEL
:
2434 p
= "!$OMP PARALLEL";
2436 case ST_OMP_PARALLEL_DO
:
2437 p
= "!$OMP PARALLEL DO";
2439 case ST_OMP_PARALLEL_DO_SIMD
:
2440 p
= "!$OMP PARALLEL DO SIMD";
2442 case ST_OMP_PARALLEL_SECTIONS
:
2443 p
= "!$OMP PARALLEL SECTIONS";
2445 case ST_OMP_PARALLEL_WORKSHARE
:
2446 p
= "!$OMP PARALLEL WORKSHARE";
2448 case ST_OMP_REQUIRES
:
2449 p
= "!$OMP REQUIRES";
2454 case ST_OMP_SECTIONS
:
2455 p
= "!$OMP SECTIONS";
2457 case ST_OMP_SECTION
:
2458 p
= "!$OMP SECTION";
2469 case ST_OMP_TARGET_DATA
:
2470 p
= "!$OMP TARGET DATA";
2472 case ST_OMP_TARGET_ENTER_DATA
:
2473 p
= "!$OMP TARGET ENTER DATA";
2475 case ST_OMP_TARGET_EXIT_DATA
:
2476 p
= "!$OMP TARGET EXIT DATA";
2478 case ST_OMP_TARGET_PARALLEL
:
2479 p
= "!$OMP TARGET PARALLEL";
2481 case ST_OMP_TARGET_PARALLEL_DO
:
2482 p
= "!$OMP TARGET PARALLEL DO";
2484 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
2485 p
= "!$OMP TARGET PARALLEL DO SIMD";
2487 case ST_OMP_TARGET_SIMD
:
2488 p
= "!$OMP TARGET SIMD";
2490 case ST_OMP_TARGET_TEAMS
:
2491 p
= "!$OMP TARGET TEAMS";
2493 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
2494 p
= "!$OMP TARGET TEAMS DISTRIBUTE";
2496 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2497 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2499 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2500 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2502 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2503 p
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2505 case ST_OMP_TARGET_UPDATE
:
2506 p
= "!$OMP TARGET UPDATE";
2511 case ST_OMP_TASKGROUP
:
2512 p
= "!$OMP TASKGROUP";
2514 case ST_OMP_TASKLOOP
:
2515 p
= "!$OMP TASKLOOP";
2517 case ST_OMP_TASKLOOP_SIMD
:
2518 p
= "!$OMP TASKLOOP SIMD";
2520 case ST_OMP_TASKWAIT
:
2521 p
= "!$OMP TASKWAIT";
2523 case ST_OMP_TASKYIELD
:
2524 p
= "!$OMP TASKYIELD";
2529 case ST_OMP_TEAMS_DISTRIBUTE
:
2530 p
= "!$OMP TEAMS DISTRIBUTE";
2532 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2533 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2535 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2536 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2538 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
2539 p
= "!$OMP TEAMS DISTRIBUTE SIMD";
2541 case ST_OMP_THREADPRIVATE
:
2542 p
= "!$OMP THREADPRIVATE";
2544 case ST_OMP_WORKSHARE
:
2545 p
= "!$OMP WORKSHARE";
2548 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2555 /* Create a symbol for the main program and assign it to ns->proc_name. */
2558 main_program_symbol (gfc_namespace
*ns
, const char *name
)
2560 gfc_symbol
*main_program
;
2561 symbol_attribute attr
;
2563 gfc_get_symbol (name
, ns
, &main_program
);
2564 gfc_clear_attr (&attr
);
2565 attr
.flavor
= FL_PROGRAM
;
2566 attr
.proc
= PROC_UNKNOWN
;
2567 attr
.subroutine
= 1;
2568 attr
.access
= ACCESS_PUBLIC
;
2569 attr
.is_main_program
= 1;
2570 main_program
->attr
= attr
;
2571 main_program
->declared_at
= gfc_current_locus
;
2572 ns
->proc_name
= main_program
;
2573 gfc_commit_symbols ();
2577 /* Do whatever is necessary to accept the last statement. */
2580 accept_statement (gfc_statement st
)
2584 case ST_IMPLICIT_NONE
:
2592 gfc_current_ns
->proc_name
= gfc_new_block
;
2595 /* If the statement is the end of a block, lay down a special code
2596 that allows a branch to the end of the block from within the
2597 construct. IF and SELECT are treated differently from DO
2598 (where EXEC_NOP is added inside the loop) for two
2600 1. END DO has a meaning in the sense that after a GOTO to
2601 it, the loop counter must be increased.
2602 2. IF blocks and SELECT blocks can consist of multiple
2603 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
2604 Putting the label before the END IF would make the jump
2605 from, say, the ELSE IF block to the END IF illegal. */
2609 case ST_END_CRITICAL
:
2610 if (gfc_statement_label
!= NULL
)
2612 new_st
.op
= EXEC_END_NESTED_BLOCK
;
2617 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
2618 one parallel block. Thus, we add the special code to the nested block
2619 itself, instead of the parent one. */
2621 case ST_END_ASSOCIATE
:
2622 if (gfc_statement_label
!= NULL
)
2624 new_st
.op
= EXEC_END_BLOCK
;
2629 /* The end-of-program unit statements do not get the special
2630 marker and require a statement of some sort if they are a
2633 case ST_END_PROGRAM
:
2634 case ST_END_FUNCTION
:
2635 case ST_END_SUBROUTINE
:
2636 if (gfc_statement_label
!= NULL
)
2638 new_st
.op
= EXEC_RETURN
;
2643 new_st
.op
= EXEC_END_PROCEDURE
;
2659 gfc_commit_symbols ();
2660 gfc_warning_check ();
2661 gfc_clear_new_st ();
2665 /* Undo anything tentative that has been built for the current statement,
2666 except if a gfc_charlen structure has been added to current namespace's
2667 list of gfc_charlen structure. */
2670 reject_statement (void)
2672 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
2673 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
2675 gfc_reject_data (gfc_current_ns
);
2677 gfc_new_block
= NULL
;
2678 gfc_undo_symbols ();
2679 gfc_clear_warning ();
2680 undo_new_statement ();
2684 /* Generic complaint about an out of order statement. We also do
2685 whatever is necessary to clean up. */
2688 unexpected_statement (gfc_statement st
)
2690 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
2692 reject_statement ();
2696 /* Given the next statement seen by the matcher, make sure that it is
2697 in proper order with the last. This subroutine is initialized by
2698 calling it with an argument of ST_NONE. If there is a problem, we
2699 issue an error and return false. Otherwise we return true.
2701 Individual parsers need to verify that the statements seen are
2702 valid before calling here, i.e., ENTRY statements are not allowed in
2703 INTERFACE blocks. The following diagram is taken from the standard:
2705 +---------------------------------------+
2706 | program subroutine function module |
2707 +---------------------------------------+
2709 +---------------------------------------+
2711 +---------------------------------------+
2713 | +-----------+------------------+
2714 | | parameter | implicit |
2715 | +-----------+------------------+
2716 | format | | derived type |
2717 | entry | parameter | interface |
2718 | | data | specification |
2719 | | | statement func |
2720 | +-----------+------------------+
2721 | | data | executable |
2722 +--------+-----------+------------------+
2724 +---------------------------------------+
2725 | internal module/subprogram |
2726 +---------------------------------------+
2728 +---------------------------------------+
2737 ORDER_IMPLICIT_NONE
,
2745 enum state_order state
;
2746 gfc_statement last_statement
;
2752 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
2758 p
->state
= ORDER_START
;
2762 if (p
->state
> ORDER_USE
)
2764 p
->state
= ORDER_USE
;
2768 if (p
->state
> ORDER_IMPORT
)
2770 p
->state
= ORDER_IMPORT
;
2773 case ST_IMPLICIT_NONE
:
2774 if (p
->state
> ORDER_IMPLICIT
)
2777 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2778 statement disqualifies a USE but not an IMPLICIT NONE.
2779 Duplicate IMPLICIT NONEs are caught when the implicit types
2782 p
->state
= ORDER_IMPLICIT_NONE
;
2786 if (p
->state
> ORDER_IMPLICIT
)
2788 p
->state
= ORDER_IMPLICIT
;
2793 if (p
->state
< ORDER_IMPLICIT_NONE
)
2794 p
->state
= ORDER_IMPLICIT_NONE
;
2798 if (p
->state
>= ORDER_EXEC
)
2800 if (p
->state
< ORDER_IMPLICIT
)
2801 p
->state
= ORDER_IMPLICIT
;
2805 if (p
->state
< ORDER_SPEC
)
2806 p
->state
= ORDER_SPEC
;
2811 case ST_STRUCTURE_DECL
:
2812 case ST_DERIVED_DECL
:
2814 if (p
->state
>= ORDER_EXEC
)
2816 if (p
->state
< ORDER_SPEC
)
2817 p
->state
= ORDER_SPEC
;
2821 /* The OpenMP/OpenACC directives have to be somewhere in the specification
2822 part, but there are no further requirements on their ordering.
2823 Thus don't adjust p->state, just ignore them. */
2824 if (p
->state
>= ORDER_EXEC
)
2830 if (p
->state
< ORDER_EXEC
)
2831 p
->state
= ORDER_EXEC
;
2838 /* All is well, record the statement in case we need it next time. */
2839 p
->where
= gfc_current_locus
;
2840 p
->last_statement
= st
;
2845 gfc_error ("%s statement at %C cannot follow %s statement at %L",
2846 gfc_ascii_statement (st
),
2847 gfc_ascii_statement (p
->last_statement
), &p
->where
);
2853 /* Handle an unexpected end of file. This is a show-stopper... */
2855 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
2858 unexpected_eof (void)
2862 gfc_error ("Unexpected end of file in %qs", gfc_source_file
);
2864 /* Memory cleanup. Move to "second to last". */
2865 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
2868 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
2871 longjmp (eof_buf
, 1);
2873 /* Avoids build error on systems where longjmp is not declared noreturn. */
2878 /* Parse the CONTAINS section of a derived type definition. */
2880 gfc_access gfc_typebound_default_access
;
2883 parse_derived_contains (void)
2886 bool seen_private
= false;
2887 bool seen_comps
= false;
2888 bool error_flag
= false;
2891 gcc_assert (gfc_current_state () == COMP_DERIVED
);
2892 gcc_assert (gfc_current_block ());
2894 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
2896 if (gfc_current_block ()->attr
.sequence
)
2897 gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
2898 " section at %C", gfc_current_block ()->name
);
2899 if (gfc_current_block ()->attr
.is_bind_c
)
2900 gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
2901 " section at %C", gfc_current_block ()->name
);
2903 accept_statement (ST_CONTAINS
);
2904 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
2906 gfc_typebound_default_access
= ACCESS_PUBLIC
;
2912 st
= next_statement ();
2920 gfc_error ("Components in TYPE at %C must precede CONTAINS");
2924 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
2927 accept_statement (ST_PROCEDURE
);
2932 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
2935 accept_statement (ST_GENERIC
);
2940 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
2944 accept_statement (ST_FINAL
);
2952 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
2953 "at %C with empty CONTAINS section")))
2956 /* ST_END_TYPE is accepted by parse_derived after return. */
2960 if (!gfc_find_state (COMP_MODULE
))
2962 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2969 gfc_error ("PRIVATE statement at %C must precede procedure"
2976 gfc_error ("Duplicate PRIVATE statement at %C");
2980 accept_statement (ST_PRIVATE
);
2981 gfc_typebound_default_access
= ACCESS_PRIVATE
;
2982 seen_private
= true;
2986 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
2990 gfc_error ("Already inside a CONTAINS block at %C");
2994 unexpected_statement (st
);
3002 reject_statement ();
3006 gcc_assert (gfc_current_state () == COMP_DERIVED
);
3012 /* Set attributes for the parent symbol based on the attributes of a component
3013 and raise errors if conflicting attributes are found for the component. */
3016 check_component (gfc_symbol
*sym
, gfc_component
*c
, gfc_component
**lockp
,
3017 gfc_component
**eventp
)
3019 bool coarray
, lock_type
, event_type
, allocatable
, pointer
;
3020 coarray
= lock_type
= event_type
= allocatable
= pointer
= false;
3021 gfc_component
*lock_comp
= NULL
, *event_comp
= NULL
;
3023 if (lockp
) lock_comp
= *lockp
;
3024 if (eventp
) event_comp
= *eventp
;
3026 /* Look for allocatable components. */
3027 if (c
->attr
.allocatable
3028 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3029 && CLASS_DATA (c
)->attr
.allocatable
)
3030 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
3031 && c
->ts
.u
.derived
->attr
.alloc_comp
))
3034 sym
->attr
.alloc_comp
= 1;
3037 /* Look for pointer components. */
3039 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3040 && CLASS_DATA (c
)->attr
.class_pointer
)
3041 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
3044 sym
->attr
.pointer_comp
= 1;
3047 /* Look for procedure pointer components. */
3048 if (c
->attr
.proc_pointer
3049 || (c
->ts
.type
== BT_DERIVED
3050 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
3051 sym
->attr
.proc_pointer_comp
= 1;
3053 /* Looking for coarray components. */
3054 if (c
->attr
.codimension
3055 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3056 && CLASS_DATA (c
)->attr
.codimension
))
3059 sym
->attr
.coarray_comp
= 1;
3062 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
3063 && !c
->attr
.pointer
)
3066 sym
->attr
.coarray_comp
= 1;
3069 /* Looking for lock_type components. */
3070 if ((c
->ts
.type
== BT_DERIVED
3071 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3072 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3073 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3074 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
3075 == INTMOD_ISO_FORTRAN_ENV
3076 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
3077 == ISOFORTRAN_LOCK_TYPE
)
3078 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
3079 && !allocatable
&& !pointer
))
3083 sym
->attr
.lock_comp
= 1;
3086 /* Looking for event_type components. */
3087 if ((c
->ts
.type
== BT_DERIVED
3088 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3089 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
3090 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3091 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
3092 == INTMOD_ISO_FORTRAN_ENV
3093 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
3094 == ISOFORTRAN_EVENT_TYPE
)
3095 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.event_comp
3096 && !allocatable
&& !pointer
))
3100 sym
->attr
.event_comp
= 1;
3103 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
3104 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
3105 unless there are nondirect [allocatable or pointer] components
3106 involved (cf. 1.3.33.1 and 1.3.33.3). */
3108 if (pointer
&& !coarray
&& lock_type
)
3109 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
3110 "codimension or be a subcomponent of a coarray, "
3111 "which is not possible as the component has the "
3112 "pointer attribute", c
->name
, &c
->loc
);
3113 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
3114 && c
->ts
.u
.derived
->attr
.lock_comp
)
3115 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3116 "of type LOCK_TYPE, which must have a codimension or be a "
3117 "subcomponent of a coarray", c
->name
, &c
->loc
);
3119 if (lock_type
&& allocatable
&& !coarray
)
3120 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
3121 "a codimension", c
->name
, &c
->loc
);
3122 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
3123 && c
->ts
.u
.derived
->attr
.lock_comp
)
3124 gfc_error ("Allocatable component %s at %L must have a codimension as "
3125 "it has a noncoarray subcomponent of type LOCK_TYPE",
3128 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
3129 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3130 "subcomponent of type LOCK_TYPE must have a codimension or "
3131 "be a subcomponent of a coarray. (Variables of type %s may "
3132 "not have a codimension as already a coarray "
3133 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
3135 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
3136 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3137 "subcomponent of type LOCK_TYPE must have a codimension or "
3138 "be a subcomponent of a coarray. (Variables of type %s may "
3139 "not have a codimension as %s at %L has a codimension or a "
3140 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
3141 sym
->name
, c
->name
, &c
->loc
);
3143 /* Similarly for EVENT TYPE. */
3145 if (pointer
&& !coarray
&& event_type
)
3146 gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
3147 "codimension or be a subcomponent of a coarray, "
3148 "which is not possible as the component has the "
3149 "pointer attribute", c
->name
, &c
->loc
);
3150 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
3151 && c
->ts
.u
.derived
->attr
.event_comp
)
3152 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3153 "of type EVENT_TYPE, which must have a codimension or be a "
3154 "subcomponent of a coarray", c
->name
, &c
->loc
);
3156 if (event_type
&& allocatable
&& !coarray
)
3157 gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
3158 "a codimension", c
->name
, &c
->loc
);
3159 else if (event_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
3160 && c
->ts
.u
.derived
->attr
.event_comp
)
3161 gfc_error ("Allocatable component %s at %L must have a codimension as "
3162 "it has a noncoarray subcomponent of type EVENT_TYPE",
3165 if (sym
->attr
.coarray_comp
&& !coarray
&& event_type
)
3166 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3167 "subcomponent of type EVENT_TYPE must have a codimension or "
3168 "be a subcomponent of a coarray. (Variables of type %s may "
3169 "not have a codimension as already a coarray "
3170 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
3172 if (sym
->attr
.event_comp
&& coarray
&& !event_type
)
3173 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3174 "subcomponent of type EVENT_TYPE must have a codimension or "
3175 "be a subcomponent of a coarray. (Variables of type %s may "
3176 "not have a codimension as %s at %L has a codimension or a "
3177 "coarray subcomponent)", event_comp
->name
, &event_comp
->loc
,
3178 sym
->name
, c
->name
, &c
->loc
);
3180 /* Look for private components. */
3181 if (sym
->component_access
== ACCESS_PRIVATE
3182 || c
->attr
.access
== ACCESS_PRIVATE
3183 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
3184 sym
->attr
.private_comp
= 1;
3186 if (lockp
) *lockp
= lock_comp
;
3187 if (eventp
) *eventp
= event_comp
;
3191 static void parse_struct_map (gfc_statement
);
3193 /* Parse a union component definition within a structure definition. */
3201 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3204 accept_statement(ST_UNION
);
3205 push_state (&s
, COMP_UNION
, gfc_new_block
);
3212 st
= next_statement ();
3213 /* Only MAP declarations valid within a union. */
3220 accept_statement (ST_MAP
);
3221 parse_struct_map (ST_MAP
);
3222 /* Add a component to the union for each map. */
3223 if (!gfc_add_component (un
, gfc_new_block
->name
, &c
))
3225 gfc_internal_error ("failed to create map component '%s'",
3226 gfc_new_block
->name
);
3227 reject_statement ();
3230 c
->ts
.type
= BT_DERIVED
;
3231 c
->ts
.u
.derived
= gfc_new_block
;
3232 /* Normally components get their initialization expressions when they
3233 are created in decl.c (build_struct) so we can look through the
3234 flat component list for initializers during resolution. Unions and
3235 maps create components along with their type definitions so we
3236 have to generate initializers here. */
3237 c
->initializer
= gfc_default_initializer (&c
->ts
);
3242 accept_statement (ST_END_UNION
);
3246 unexpected_statement (st
);
3251 for (c
= un
->components
; c
; c
= c
->next
)
3252 check_component (un
, c
, &lock_comp
, &event_comp
);
3254 /* Add the union as a component in its parent structure. */
3256 if (!gfc_add_component (gfc_current_block (), un
->name
, &c
))
3258 gfc_internal_error ("failed to create union component '%s'", un
->name
);
3259 reject_statement ();
3262 c
->ts
.type
= BT_UNION
;
3263 c
->ts
.u
.derived
= un
;
3264 c
->initializer
= gfc_default_initializer (&c
->ts
);
3266 un
->attr
.zero_comp
= un
->components
== NULL
;
3270 /* Parse a STRUCTURE or MAP. */
3273 parse_struct_map (gfc_statement block
)
3279 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3280 gfc_compile_state comp
;
3283 if (block
== ST_STRUCTURE_DECL
)
3285 comp
= COMP_STRUCTURE
;
3286 ends
= ST_END_STRUCTURE
;
3290 gcc_assert (block
== ST_MAP
);
3295 accept_statement(block
);
3296 push_state (&s
, comp
, gfc_new_block
);
3298 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3301 while (compiling_type
)
3303 st
= next_statement ();
3309 /* Nested structure declarations will be captured as ST_DATA_DECL. */
3310 case ST_STRUCTURE_DECL
:
3311 /* Let a more specific error make it to decode_statement(). */
3312 if (gfc_error_check () == 0)
3313 gfc_error ("Syntax error in nested structure declaration at %C");
3314 reject_statement ();
3315 /* Skip the rest of this statement. */
3316 gfc_error_recovery ();
3320 accept_statement (ST_UNION
);
3325 /* The data declaration was a nested/ad-hoc STRUCTURE field. */
3326 accept_statement (ST_DATA_DECL
);
3327 if (gfc_new_block
&& gfc_new_block
!= gfc_current_block ()
3328 && gfc_new_block
->attr
.flavor
== FL_STRUCT
)
3329 parse_struct_map (ST_STRUCTURE_DECL
);
3332 case ST_END_STRUCTURE
:
3336 accept_statement (st
);
3340 unexpected_statement (st
);
3344 unexpected_statement (st
);
3349 /* Validate each component. */
3350 sym
= gfc_current_block ();
3351 for (c
= sym
->components
; c
; c
= c
->next
)
3352 check_component (sym
, c
, &lock_comp
, &event_comp
);
3354 sym
->attr
.zero_comp
= (sym
->components
== NULL
);
3356 /* Allow parse_union to find this structure to add to its list of maps. */
3357 if (block
== ST_MAP
)
3358 gfc_new_block
= gfc_current_block ();
3364 /* Parse a derived type. */
3367 parse_derived (void)
3369 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
3373 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3375 accept_statement (ST_DERIVED_DECL
);
3376 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
3378 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3385 while (compiling_type
)
3387 st
= next_statement ();
3395 accept_statement (st
);
3400 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
3407 if (!seen_component
)
3408 gfc_notify_std (GFC_STD_F2003
, "Derived type "
3409 "definition at %C without components");
3411 accept_statement (ST_END_TYPE
);
3415 if (!gfc_find_state (COMP_MODULE
))
3417 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3424 gfc_error ("PRIVATE statement at %C must precede "
3425 "structure components");
3430 gfc_error ("Duplicate PRIVATE statement at %C");
3432 s
.sym
->component_access
= ACCESS_PRIVATE
;
3434 accept_statement (ST_PRIVATE
);
3441 gfc_error ("SEQUENCE statement at %C must precede "
3442 "structure components");
3446 if (gfc_current_block ()->attr
.sequence
)
3447 gfc_warning (0, "SEQUENCE attribute at %C already specified in "
3452 gfc_error ("Duplicate SEQUENCE statement at %C");
3456 gfc_add_sequence (&gfc_current_block ()->attr
,
3457 gfc_current_block ()->name
, NULL
);
3461 gfc_notify_std (GFC_STD_F2003
,
3462 "CONTAINS block in derived type"
3463 " definition at %C");
3465 accept_statement (ST_CONTAINS
);
3466 parse_derived_contains ();
3470 unexpected_statement (st
);
3475 /* need to verify that all fields of the derived type are
3476 * interoperable with C if the type is declared to be bind(c)
3478 sym
= gfc_current_block ();
3479 for (c
= sym
->components
; c
; c
= c
->next
)
3480 check_component (sym
, c
, &lock_comp
, &event_comp
);
3482 if (!seen_component
)
3483 sym
->attr
.zero_comp
= 1;
3489 /* Parse an ENUM. */
3497 int seen_enumerator
= 0;
3499 push_state (&s
, COMP_ENUM
, gfc_new_block
);
3503 while (compiling_enum
)
3505 st
= next_statement ();
3513 seen_enumerator
= 1;
3514 accept_statement (st
);
3519 if (!seen_enumerator
)
3520 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
3521 accept_statement (st
);
3525 gfc_free_enum_history ();
3526 unexpected_statement (st
);
3534 /* Parse an interface. We must be able to deal with the possibility
3535 of recursive interfaces. The parse_spec() subroutine is mutually
3536 recursive with parse_interface(). */
3538 static gfc_statement
parse_spec (gfc_statement
);
3541 parse_interface (void)
3543 gfc_compile_state new_state
= COMP_NONE
, current_state
;
3544 gfc_symbol
*prog_unit
, *sym
;
3545 gfc_interface_info save
;
3546 gfc_state_data s1
, s2
;
3549 accept_statement (ST_INTERFACE
);
3551 current_interface
.ns
= gfc_current_ns
;
3552 save
= current_interface
;
3554 sym
= (current_interface
.type
== INTERFACE_GENERIC
3555 || current_interface
.type
== INTERFACE_USER_OP
)
3556 ? gfc_new_block
: NULL
;
3558 push_state (&s1
, COMP_INTERFACE
, sym
);
3559 current_state
= COMP_NONE
;
3562 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
3564 st
= next_statement ();
3572 if (st
== ST_SUBROUTINE
)
3573 new_state
= COMP_SUBROUTINE
;
3574 else if (st
== ST_FUNCTION
)
3575 new_state
= COMP_FUNCTION
;
3576 if (gfc_new_block
->attr
.pointer
)
3578 gfc_new_block
->attr
.pointer
= 0;
3579 gfc_new_block
->attr
.proc_pointer
= 1;
3581 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
3582 gfc_new_block
->formal
, NULL
))
3584 reject_statement ();
3585 gfc_free_namespace (gfc_current_ns
);
3588 /* F2008 C1210 forbids the IMPORT statement in module procedure
3589 interface bodies and the flag is set to import symbols. */
3590 if (gfc_new_block
->attr
.module_procedure
)
3591 gfc_current_ns
->has_import_set
= 1;
3595 case ST_MODULE_PROC
: /* The module procedure matcher makes
3596 sure the context is correct. */
3597 accept_statement (st
);
3598 gfc_free_namespace (gfc_current_ns
);
3601 case ST_END_INTERFACE
:
3602 gfc_free_namespace (gfc_current_ns
);
3603 gfc_current_ns
= current_interface
.ns
;
3607 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
3608 gfc_ascii_statement (st
));
3609 reject_statement ();
3610 gfc_free_namespace (gfc_current_ns
);
3615 /* Make sure that the generic name has the right attribute. */
3616 if (current_interface
.type
== INTERFACE_GENERIC
3617 && current_state
== COMP_NONE
)
3619 if (new_state
== COMP_FUNCTION
&& sym
)
3620 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
3621 else if (new_state
== COMP_SUBROUTINE
&& sym
)
3622 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
3624 current_state
= new_state
;
3627 if (current_interface
.type
== INTERFACE_ABSTRACT
)
3629 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
3630 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
3631 gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
3632 "cannot be the same as an intrinsic type",
3633 gfc_new_block
->name
);
3636 push_state (&s2
, new_state
, gfc_new_block
);
3637 accept_statement (st
);
3638 prog_unit
= gfc_new_block
;
3639 prog_unit
->formal_ns
= gfc_current_ns
;
3640 if (prog_unit
== prog_unit
->formal_ns
->proc_name
3641 && prog_unit
->ns
!= prog_unit
->formal_ns
)
3645 /* Read data declaration statements. */
3646 st
= parse_spec (ST_NONE
);
3647 in_specification_block
= true;
3649 /* Since the interface block does not permit an IMPLICIT statement,
3650 the default type for the function or the result must be taken
3651 from the formal namespace. */
3652 if (new_state
== COMP_FUNCTION
)
3654 if (prog_unit
->result
== prog_unit
3655 && prog_unit
->ts
.type
== BT_UNKNOWN
)
3656 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
3657 else if (prog_unit
->result
!= prog_unit
3658 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
3659 gfc_set_default_type (prog_unit
->result
, 1,
3660 prog_unit
->formal_ns
);
3663 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
3665 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
3666 gfc_ascii_statement (st
));
3667 reject_statement ();
3671 /* Add EXTERNAL attribute to function or subroutine. */
3672 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
3673 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
3675 current_interface
= save
;
3676 gfc_add_interface (prog_unit
);
3679 if (current_interface
.ns
3680 && current_interface
.ns
->proc_name
3681 && strcmp (current_interface
.ns
->proc_name
->name
,
3682 prog_unit
->name
) == 0)
3683 gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
3684 "enclosing procedure", prog_unit
->name
,
3685 ¤t_interface
.ns
->proc_name
->declared_at
);
3694 /* Associate function characteristics by going back to the function
3695 declaration and rematching the prefix. */
3698 match_deferred_characteristics (gfc_typespec
* ts
)
3701 match m
= MATCH_ERROR
;
3702 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
3704 loc
= gfc_current_locus
;
3706 gfc_current_locus
= gfc_current_block ()->declared_at
;
3709 gfc_buffer_error (true);
3710 m
= gfc_match_prefix (ts
);
3711 gfc_buffer_error (false);
3713 if (ts
->type
== BT_DERIVED
)
3721 /* Only permit one go at the characteristic association. */
3725 /* Set the function locus correctly. If we have not found the
3726 function name, there is an error. */
3728 && gfc_match ("function% %n", name
) == MATCH_YES
3729 && strcmp (name
, gfc_current_block ()->name
) == 0)
3731 gfc_current_block ()->declared_at
= gfc_current_locus
;
3732 gfc_commit_symbols ();
3737 gfc_undo_symbols ();
3740 gfc_current_locus
=loc
;
3745 /* Check specification-expressions in the function result of the currently
3746 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
3747 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
3748 scope are not yet parsed so this has to be delayed up to parse_spec. */
3751 check_function_result_typed (void)
3755 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
3757 if (!gfc_current_ns
->proc_name
->result
) return;
3759 ts
= gfc_current_ns
->proc_name
->result
->ts
;
3761 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
3762 /* TODO: Extend when KIND type parameters are implemented. */
3763 if (ts
.type
== BT_CHARACTER
&& ts
.u
.cl
&& ts
.u
.cl
->length
)
3764 gfc_expr_check_typed (ts
.u
.cl
->length
, gfc_current_ns
, true);
3768 /* Parse a set of specification statements. Returns the statement
3769 that doesn't fit. */
3771 static gfc_statement
3772 parse_spec (gfc_statement st
)
3775 bool function_result_typed
= false;
3776 bool bad_characteristic
= false;
3779 in_specification_block
= true;
3781 verify_st_order (&ss
, ST_NONE
, false);
3783 st
= next_statement ();
3785 /* If we are not inside a function or don't have a result specified so far,
3786 do nothing special about it. */
3787 if (gfc_current_state () != COMP_FUNCTION
)
3788 function_result_typed
= true;
3791 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
3794 if (proc
->result
->ts
.type
== BT_UNKNOWN
)
3795 function_result_typed
= true;
3800 /* If we're inside a BLOCK construct, some statements are disallowed.
3801 Check this here. Attribute declaration statements like INTENT, OPTIONAL
3802 or VALUE are also disallowed, but they don't have a particular ST_*
3803 key so we have to check for them individually in their matcher routine. */
3804 if (gfc_current_state () == COMP_BLOCK
)
3808 case ST_IMPLICIT_NONE
:
3811 case ST_EQUIVALENCE
:
3812 case ST_STATEMENT_FUNCTION
:
3813 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
3814 gfc_ascii_statement (st
));
3815 reject_statement ();
3821 else if (gfc_current_state () == COMP_BLOCK_DATA
)
3822 /* Fortran 2008, C1116. */
3829 case ST_DERIVED_DECL
:
3830 case ST_END_BLOCK_DATA
:
3831 case ST_EQUIVALENCE
:
3833 case ST_IMPLICIT_NONE
:
3834 case ST_OMP_THREADPRIVATE
:
3836 case ST_STRUCTURE_DECL
:
3845 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
3846 gfc_ascii_statement (st
));
3847 reject_statement ();
3851 /* If we find a statement that cannot be followed by an IMPLICIT statement
3852 (and thus we can expect to see none any further), type the function result
3853 if it has not yet been typed. Be careful not to give the END statement
3854 to verify_st_order! */
3855 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
3857 bool verify_now
= false;
3859 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
3864 verify_st_order (&dummyss
, ST_NONE
, false);
3865 verify_st_order (&dummyss
, st
, false);
3867 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
3873 check_function_result_typed ();
3874 function_result_typed
= true;
3883 case ST_IMPLICIT_NONE
:
3885 if (!function_result_typed
)
3887 check_function_result_typed ();
3888 function_result_typed
= true;
3894 case ST_DATA
: /* Not allowed in interfaces */
3895 if (gfc_current_state () == COMP_INTERFACE
)
3905 case ST_STRUCTURE_DECL
:
3906 case ST_DERIVED_DECL
:
3910 if (!verify_st_order (&ss
, st
, false))
3912 reject_statement ();
3913 st
= next_statement ();
3923 case ST_STRUCTURE_DECL
:
3924 parse_struct_map (ST_STRUCTURE_DECL
);
3927 case ST_DERIVED_DECL
:
3933 if (gfc_current_state () != COMP_MODULE
)
3935 gfc_error ("%s statement must appear in a MODULE",
3936 gfc_ascii_statement (st
));
3937 reject_statement ();
3941 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
3943 gfc_error ("%s statement at %C follows another accessibility "
3944 "specification", gfc_ascii_statement (st
));
3945 reject_statement ();
3949 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
3950 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
3954 case ST_STATEMENT_FUNCTION
:
3955 if (gfc_current_state () == COMP_MODULE
3956 || gfc_current_state () == COMP_SUBMODULE
)
3958 unexpected_statement (st
);
3966 accept_statement (st
);
3967 st
= next_statement ();
3971 accept_statement (st
);
3973 st
= next_statement ();
3976 case ST_GET_FCN_CHARACTERISTICS
:
3977 /* This statement triggers the association of a function's result
3979 ts
= &gfc_current_block ()->result
->ts
;
3980 if (match_deferred_characteristics (ts
) != MATCH_YES
)
3981 bad_characteristic
= true;
3983 st
= next_statement ();
3990 /* If match_deferred_characteristics failed, then there is an error. */
3991 if (bad_characteristic
)
3993 ts
= &gfc_current_block ()->result
->ts
;
3994 if (ts
->type
!= BT_DERIVED
)
3995 gfc_error ("Bad kind expression for function %qs at %L",
3996 gfc_current_block ()->name
,
3997 &gfc_current_block ()->declared_at
);
3999 gfc_error ("The type for function %qs at %L is not accessible",
4000 gfc_current_block ()->name
,
4001 &gfc_current_block ()->declared_at
);
4003 gfc_current_block ()->ts
.kind
= 0;
4004 /* Keep the derived type; if it's bad, it will be discovered later. */
4005 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
4006 ts
->type
= BT_UNKNOWN
;
4009 in_specification_block
= false;
4015 /* Parse a WHERE block, (not a simple WHERE statement). */
4018 parse_where_block (void)
4020 int seen_empty_else
;
4025 accept_statement (ST_WHERE_BLOCK
);
4026 top
= gfc_state_stack
->tail
;
4028 push_state (&s
, COMP_WHERE
, gfc_new_block
);
4030 d
= add_statement ();
4031 d
->expr1
= top
->expr1
;
4037 seen_empty_else
= 0;
4041 st
= next_statement ();
4047 case ST_WHERE_BLOCK
:
4048 parse_where_block ();
4053 accept_statement (st
);
4057 if (seen_empty_else
)
4059 gfc_error ("ELSEWHERE statement at %C follows previous "
4060 "unmasked ELSEWHERE");
4061 reject_statement ();
4065 if (new_st
.expr1
== NULL
)
4066 seen_empty_else
= 1;
4068 d
= new_level (gfc_state_stack
->head
);
4070 d
->expr1
= new_st
.expr1
;
4072 accept_statement (st
);
4077 accept_statement (st
);
4081 gfc_error ("Unexpected %s statement in WHERE block at %C",
4082 gfc_ascii_statement (st
));
4083 reject_statement ();
4087 while (st
!= ST_END_WHERE
);
4093 /* Parse a FORALL block (not a simple FORALL statement). */
4096 parse_forall_block (void)
4102 accept_statement (ST_FORALL_BLOCK
);
4103 top
= gfc_state_stack
->tail
;
4105 push_state (&s
, COMP_FORALL
, gfc_new_block
);
4107 d
= add_statement ();
4108 d
->op
= EXEC_FORALL
;
4113 st
= next_statement ();
4118 case ST_POINTER_ASSIGNMENT
:
4121 accept_statement (st
);
4124 case ST_WHERE_BLOCK
:
4125 parse_where_block ();
4128 case ST_FORALL_BLOCK
:
4129 parse_forall_block ();
4133 accept_statement (st
);
4140 gfc_error ("Unexpected %s statement in FORALL block at %C",
4141 gfc_ascii_statement (st
));
4143 reject_statement ();
4147 while (st
!= ST_END_FORALL
);
4153 static gfc_statement
parse_executable (gfc_statement
);
4155 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
4158 parse_if_block (void)
4167 accept_statement (ST_IF_BLOCK
);
4169 top
= gfc_state_stack
->tail
;
4170 push_state (&s
, COMP_IF
, gfc_new_block
);
4172 new_st
.op
= EXEC_IF
;
4173 d
= add_statement ();
4175 d
->expr1
= top
->expr1
;
4181 st
= parse_executable (ST_NONE
);
4191 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
4192 "statement at %L", &else_locus
);
4194 reject_statement ();
4198 d
= new_level (gfc_state_stack
->head
);
4200 d
->expr1
= new_st
.expr1
;
4202 accept_statement (st
);
4209 gfc_error ("Duplicate ELSE statements at %L and %C",
4211 reject_statement ();
4216 else_locus
= gfc_current_locus
;
4218 d
= new_level (gfc_state_stack
->head
);
4221 accept_statement (st
);
4229 unexpected_statement (st
);
4233 while (st
!= ST_ENDIF
);
4236 accept_statement (st
);
4240 /* Parse a SELECT block. */
4243 parse_select_block (void)
4249 accept_statement (ST_SELECT_CASE
);
4251 cp
= gfc_state_stack
->tail
;
4252 push_state (&s
, COMP_SELECT
, gfc_new_block
);
4254 /* Make sure that the next statement is a CASE or END SELECT. */
4257 st
= next_statement ();
4260 if (st
== ST_END_SELECT
)
4262 /* Empty SELECT CASE is OK. */
4263 accept_statement (st
);
4270 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
4273 reject_statement ();
4276 /* At this point, we've got a nonempty select block. */
4277 cp
= new_level (cp
);
4280 accept_statement (st
);
4284 st
= parse_executable (ST_NONE
);
4291 cp
= new_level (gfc_state_stack
->head
);
4293 gfc_clear_new_st ();
4295 accept_statement (st
);
4301 /* Can't have an executable statement because of
4302 parse_executable(). */
4304 unexpected_statement (st
);
4308 while (st
!= ST_END_SELECT
);
4311 accept_statement (st
);
4315 /* Pop the current selector from the SELECT TYPE stack. */
4318 select_type_pop (void)
4320 gfc_select_type_stack
*old
= select_type_stack
;
4321 select_type_stack
= old
->prev
;
4326 /* Parse a SELECT TYPE construct (F03:R821). */
4329 parse_select_type_block (void)
4335 gfc_current_ns
= new_st
.ext
.block
.ns
;
4336 accept_statement (ST_SELECT_TYPE
);
4338 cp
= gfc_state_stack
->tail
;
4339 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
4341 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
4345 st
= next_statement ();
4348 if (st
== ST_END_SELECT
)
4349 /* Empty SELECT CASE is OK. */
4351 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
4354 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
4355 "following SELECT TYPE at %C");
4357 reject_statement ();
4360 /* At this point, we've got a nonempty select block. */
4361 cp
= new_level (cp
);
4364 accept_statement (st
);
4368 st
= parse_executable (ST_NONE
);
4376 cp
= new_level (gfc_state_stack
->head
);
4378 gfc_clear_new_st ();
4380 accept_statement (st
);
4386 /* Can't have an executable statement because of
4387 parse_executable(). */
4389 unexpected_statement (st
);
4393 while (st
!= ST_END_SELECT
);
4397 accept_statement (st
);
4398 gfc_current_ns
= gfc_current_ns
->parent
;
4403 /* Parse a SELECT RANK construct. */
4406 parse_select_rank_block (void)
4412 gfc_current_ns
= new_st
.ext
.block
.ns
;
4413 accept_statement (ST_SELECT_RANK
);
4415 cp
= gfc_state_stack
->tail
;
4416 push_state (&s
, COMP_SELECT_RANK
, gfc_new_block
);
4418 /* Make sure that the next statement is a RANK IS or RANK DEFAULT. */
4421 st
= next_statement ();
4424 if (st
== ST_END_SELECT
)
4425 /* Empty SELECT CASE is OK. */
4430 gfc_error ("Expected RANK or RANK DEFAULT "
4431 "following SELECT RANK at %C");
4433 reject_statement ();
4436 /* At this point, we've got a nonempty select block. */
4437 cp
= new_level (cp
);
4440 accept_statement (st
);
4444 st
= parse_executable (ST_NONE
);
4451 cp
= new_level (gfc_state_stack
->head
);
4453 gfc_clear_new_st ();
4455 accept_statement (st
);
4461 /* Can't have an executable statement because of
4462 parse_executable(). */
4464 unexpected_statement (st
);
4468 while (st
!= ST_END_SELECT
);
4472 accept_statement (st
);
4473 gfc_current_ns
= gfc_current_ns
->parent
;
4478 /* Given a symbol, make sure it is not an iteration variable for a DO
4479 statement. This subroutine is called when the symbol is seen in a
4480 context that causes it to become redefined. If the symbol is an
4481 iterator, we generate an error message and return nonzero. */
4484 gfc_check_do_variable (gfc_symtree
*st
)
4488 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
4489 if (s
->do_variable
== st
)
4491 gfc_error_now ("Variable %qs at %C cannot be redefined inside "
4492 "loop beginning at %L", st
->name
, &s
->head
->loc
);
4500 /* Checks to see if the current statement label closes an enddo.
4501 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
4502 an error) if it incorrectly closes an ENDDO. */
4505 check_do_closure (void)
4509 if (gfc_statement_label
== NULL
)
4512 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
4513 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4517 return 0; /* No loops to close */
4519 if (p
->ext
.end_do_label
== gfc_statement_label
)
4521 if (p
== gfc_state_stack
)
4524 gfc_error ("End of nonblock DO statement at %C is within another block");
4528 /* At this point, the label doesn't terminate the innermost loop.
4529 Make sure it doesn't terminate another one. */
4530 for (; p
; p
= p
->previous
)
4531 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4532 && p
->ext
.end_do_label
== gfc_statement_label
)
4534 gfc_error ("End of nonblock DO statement at %C is interwoven "
4535 "with another DO loop");
4543 /* Parse a series of contained program units. */
4545 static void parse_progunit (gfc_statement
);
4548 /* Parse a CRITICAL block. */
4551 parse_critical_block (void)
4554 gfc_state_data s
, *sd
;
4557 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4558 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
4559 gfc_error_now (is_oacc (sd
)
4560 ? G_("CRITICAL block inside of OpenACC region at %C")
4561 : G_("CRITICAL block inside of OpenMP region at %C"));
4563 s
.ext
.end_do_label
= new_st
.label1
;
4565 accept_statement (ST_CRITICAL
);
4566 top
= gfc_state_stack
->tail
;
4568 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
4570 d
= add_statement ();
4571 d
->op
= EXEC_CRITICAL
;
4576 st
= parse_executable (ST_NONE
);
4584 case ST_END_CRITICAL
:
4585 if (s
.ext
.end_do_label
!= NULL
4586 && s
.ext
.end_do_label
!= gfc_statement_label
)
4587 gfc_error_now ("Statement label in END CRITICAL at %C does not "
4588 "match CRITICAL label");
4590 if (gfc_statement_label
!= NULL
)
4592 new_st
.op
= EXEC_NOP
;
4598 unexpected_statement (st
);
4602 while (st
!= ST_END_CRITICAL
);
4605 accept_statement (st
);
4609 /* Set up the local namespace for a BLOCK construct. */
4612 gfc_build_block_ns (gfc_namespace
*parent_ns
)
4614 gfc_namespace
* my_ns
;
4615 static int numblock
= 1;
4617 my_ns
= gfc_get_namespace (parent_ns
, 1);
4618 my_ns
->construct_entities
= 1;
4620 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
4621 code generation (so it must not be NULL).
4622 We set its recursive argument if our container procedure is recursive, so
4623 that local variables are accordingly placed on the stack when it
4624 will be necessary. */
4626 my_ns
->proc_name
= gfc_new_block
;
4630 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
4632 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
4633 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
4634 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
4635 my_ns
->proc_name
->name
, NULL
);
4637 gfc_commit_symbol (my_ns
->proc_name
);
4640 if (parent_ns
->proc_name
)
4641 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
4647 /* Parse a BLOCK construct. */
4650 parse_block_construct (void)
4652 gfc_namespace
* my_ns
;
4653 gfc_namespace
* my_parent
;
4656 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
4658 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4660 new_st
.op
= EXEC_BLOCK
;
4661 new_st
.ext
.block
.ns
= my_ns
;
4662 new_st
.ext
.block
.assoc
= NULL
;
4663 accept_statement (ST_BLOCK
);
4665 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
4666 gfc_current_ns
= my_ns
;
4667 my_parent
= my_ns
->parent
;
4669 parse_progunit (ST_NONE
);
4671 /* Don't depend on the value of gfc_current_ns; it might have been
4672 reset if the block had errors and was cleaned up. */
4673 gfc_current_ns
= my_parent
;
4679 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
4680 behind the scenes with compiler-generated variables. */
4683 parse_associate (void)
4685 gfc_namespace
* my_ns
;
4688 gfc_association_list
* a
;
4690 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
4692 my_ns
= gfc_build_block_ns (gfc_current_ns
);
4694 new_st
.op
= EXEC_BLOCK
;
4695 new_st
.ext
.block
.ns
= my_ns
;
4696 gcc_assert (new_st
.ext
.block
.assoc
);
4698 /* Add all associate-names as BLOCK variables. Creating them is enough
4699 for now, they'll get their values during trans-* phase. */
4700 gfc_current_ns
= my_ns
;
4701 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
4705 gfc_array_ref
*array_ref
;
4707 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
4711 sym
->attr
.flavor
= FL_VARIABLE
;
4713 sym
->declared_at
= a
->where
;
4714 gfc_set_sym_referenced (sym
);
4716 /* Initialize the typespec. It is not available in all cases,
4717 however, as it may only be set on the target during resolution.
4718 Still, sometimes it helps to have it right now -- especially
4719 for parsing component references on the associate-name
4720 in case of association to a derived-type. */
4721 sym
->ts
= a
->target
->ts
;
4723 /* Check if the target expression is array valued. This cannot always
4724 be done by looking at target.rank, because that might not have been
4725 set yet. Therefore traverse the chain of refs, looking for the last
4726 array ref and evaluate that. */
4728 for (ref
= a
->target
->ref
; ref
; ref
= ref
->next
)
4729 if (ref
->type
== REF_ARRAY
)
4730 array_ref
= &ref
->u
.ar
;
4731 if (array_ref
|| a
->target
->rank
)
4738 /* Count the dimension, that have a non-scalar extend. */
4739 for (dim
= 0; dim
< array_ref
->dimen
; ++dim
)
4740 if (array_ref
->dimen_type
[dim
] != DIMEN_ELEMENT
4741 && !(array_ref
->dimen_type
[dim
] == DIMEN_UNKNOWN
4742 && array_ref
->end
[dim
] == NULL
4743 && array_ref
->start
[dim
] != NULL
))
4747 rank
= a
->target
->rank
;
4748 /* When the rank is greater than zero then sym will be an array. */
4749 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
4751 if ((!CLASS_DATA (sym
)->as
&& rank
!= 0)
4752 || (CLASS_DATA (sym
)->as
4753 && CLASS_DATA (sym
)->as
->rank
!= rank
))
4755 /* Don't just (re-)set the attr and as in the sym.ts,
4756 because this modifies the target's attr and as. Copy the
4757 data and do a build_class_symbol. */
4758 symbol_attribute attr
= CLASS_DATA (a
->target
)->attr
;
4759 int corank
= gfc_get_corank (a
->target
);
4764 as
= gfc_get_array_spec ();
4765 as
->type
= AS_DEFERRED
;
4767 as
->corank
= corank
;
4768 attr
.dimension
= rank
? 1 : 0;
4769 attr
.codimension
= corank
? 1 : 0;
4774 attr
.dimension
= attr
.codimension
= 0;
4777 type
= CLASS_DATA (sym
)->ts
;
4778 if (!gfc_build_class_symbol (&type
,
4782 sym
->ts
.type
= BT_CLASS
;
4783 sym
->attr
.class_ok
= 1;
4786 sym
->attr
.class_ok
= 1;
4788 else if ((!sym
->as
&& rank
!= 0)
4789 || (sym
->as
&& sym
->as
->rank
!= rank
))
4791 as
= gfc_get_array_spec ();
4792 as
->type
= AS_DEFERRED
;
4794 as
->corank
= gfc_get_corank (a
->target
);
4796 sym
->attr
.dimension
= 1;
4798 sym
->attr
.codimension
= 1;
4803 accept_statement (ST_ASSOCIATE
);
4804 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
4807 st
= parse_executable (ST_NONE
);
4814 accept_statement (st
);
4815 my_ns
->code
= gfc_state_stack
->head
;
4819 unexpected_statement (st
);
4823 gfc_current_ns
= gfc_current_ns
->parent
;
4828 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
4829 handled inside of parse_executable(), because they aren't really
4833 parse_do_block (void)
4842 s
.ext
.end_do_label
= new_st
.label1
;
4844 if (new_st
.ext
.iterator
!= NULL
)
4846 stree
= new_st
.ext
.iterator
->var
->symtree
;
4847 if (directive_unroll
!= -1)
4849 new_st
.ext
.iterator
->unroll
= directive_unroll
;
4850 directive_unroll
= -1;
4852 if (directive_ivdep
)
4854 new_st
.ext
.iterator
->ivdep
= directive_ivdep
;
4855 directive_ivdep
= false;
4857 if (directive_vector
)
4859 new_st
.ext
.iterator
->vector
= directive_vector
;
4860 directive_vector
= false;
4862 if (directive_novector
)
4864 new_st
.ext
.iterator
->novector
= directive_novector
;
4865 directive_novector
= false;
4871 accept_statement (ST_DO
);
4873 top
= gfc_state_stack
->tail
;
4874 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
4877 s
.do_variable
= stree
;
4879 top
->block
= new_level (top
);
4880 top
->block
->op
= EXEC_DO
;
4883 st
= parse_executable (ST_NONE
);
4891 if (s
.ext
.end_do_label
!= NULL
4892 && s
.ext
.end_do_label
!= gfc_statement_label
)
4893 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
4896 if (gfc_statement_label
!= NULL
)
4898 new_st
.op
= EXEC_NOP
;
4903 case ST_IMPLIED_ENDDO
:
4904 /* If the do-stmt of this DO construct has a do-construct-name,
4905 the corresponding end-do must be an end-do-stmt (with a matching
4906 name, but in that case we must have seen ST_ENDDO first).
4907 We only complain about this in pedantic mode. */
4908 if (gfc_current_block () != NULL
)
4909 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
4910 &gfc_current_block()->declared_at
);
4915 unexpected_statement (st
);
4920 accept_statement (st
);
4924 /* Parse the statements of OpenMP do/parallel do. */
4926 static gfc_statement
4927 parse_omp_do (gfc_statement omp_st
)
4933 accept_statement (omp_st
);
4935 cp
= gfc_state_stack
->tail
;
4936 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
4937 np
= new_level (cp
);
4943 st
= next_statement ();
4946 else if (st
== ST_DO
)
4949 unexpected_statement (st
);
4953 if (gfc_statement_label
!= NULL
4954 && gfc_state_stack
->previous
!= NULL
4955 && gfc_state_stack
->previous
->state
== COMP_DO
4956 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
4964 there should be no !$OMP END DO. */
4966 return ST_IMPLIED_ENDDO
;
4969 check_do_closure ();
4972 st
= next_statement ();
4973 gfc_statement omp_end_st
= ST_OMP_END_DO
;
4976 case ST_OMP_DISTRIBUTE
: omp_end_st
= ST_OMP_END_DISTRIBUTE
; break;
4977 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
4978 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
4980 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
4981 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
4983 case ST_OMP_DISTRIBUTE_SIMD
:
4984 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
4986 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
4987 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
4988 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
4989 case ST_OMP_PARALLEL_DO_SIMD
:
4990 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
4992 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
4993 case ST_OMP_TARGET_PARALLEL_DO
:
4994 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO
;
4996 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
4997 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO_SIMD
;
4999 case ST_OMP_TARGET_SIMD
: omp_end_st
= ST_OMP_END_TARGET_SIMD
; break;
5000 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5001 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
5003 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5004 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5006 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5007 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5009 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5010 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
5012 case ST_OMP_TASKLOOP
: omp_end_st
= ST_OMP_END_TASKLOOP
; break;
5013 case ST_OMP_TASKLOOP_SIMD
: omp_end_st
= ST_OMP_END_TASKLOOP_SIMD
; break;
5014 case ST_OMP_TEAMS_DISTRIBUTE
:
5015 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
5017 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5018 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5020 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5021 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5023 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5024 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
5026 default: gcc_unreachable ();
5028 if (st
== omp_end_st
)
5030 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
5031 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
5033 gcc_assert (new_st
.op
== EXEC_NOP
);
5034 gfc_clear_new_st ();
5035 gfc_commit_symbols ();
5036 gfc_warning_check ();
5037 st
= next_statement ();
5043 /* Parse the statements of OpenMP atomic directive. */
5045 static gfc_statement
5046 parse_omp_oacc_atomic (bool omp_p
)
5048 gfc_statement st
, st_atomic
, st_end_atomic
;
5055 st_atomic
= ST_OMP_ATOMIC
;
5056 st_end_atomic
= ST_OMP_END_ATOMIC
;
5060 st_atomic
= ST_OACC_ATOMIC
;
5061 st_end_atomic
= ST_OACC_END_ATOMIC
;
5063 accept_statement (st_atomic
);
5065 cp
= gfc_state_stack
->tail
;
5066 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5067 np
= new_level (cp
);
5070 np
->ext
.omp_clauses
= cp
->ext
.omp_clauses
;
5071 cp
->ext
.omp_clauses
= NULL
;
5072 count
= 1 + np
->ext
.omp_clauses
->capture
;
5076 st
= next_statement ();
5079 else if (st
== ST_ASSIGNMENT
)
5081 accept_statement (st
);
5085 unexpected_statement (st
);
5090 st
= next_statement ();
5091 if (st
== st_end_atomic
)
5093 gfc_clear_new_st ();
5094 gfc_commit_symbols ();
5095 gfc_warning_check ();
5096 st
= next_statement ();
5098 else if (np
->ext
.omp_clauses
->capture
)
5099 gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
5104 /* Parse the statements of an OpenACC structured block. */
5107 parse_oacc_structured_block (gfc_statement acc_st
)
5109 gfc_statement st
, acc_end_st
;
5111 gfc_state_data s
, *sd
;
5113 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
5114 if (sd
->state
== COMP_CRITICAL
)
5115 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5117 accept_statement (acc_st
);
5119 cp
= gfc_state_stack
->tail
;
5120 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5121 np
= new_level (cp
);
5126 case ST_OACC_PARALLEL
:
5127 acc_end_st
= ST_OACC_END_PARALLEL
;
5129 case ST_OACC_KERNELS
:
5130 acc_end_st
= ST_OACC_END_KERNELS
;
5132 case ST_OACC_SERIAL
:
5133 acc_end_st
= ST_OACC_END_SERIAL
;
5136 acc_end_st
= ST_OACC_END_DATA
;
5138 case ST_OACC_HOST_DATA
:
5139 acc_end_st
= ST_OACC_END_HOST_DATA
;
5147 st
= parse_executable (ST_NONE
);
5150 else if (st
!= acc_end_st
)
5152 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
5153 reject_statement ();
5156 while (st
!= acc_end_st
);
5158 gcc_assert (new_st
.op
== EXEC_NOP
);
5160 gfc_clear_new_st ();
5161 gfc_commit_symbols ();
5162 gfc_warning_check ();
5166 /* Parse the statements of OpenACC 'loop', or combined compute 'loop'. */
5168 static gfc_statement
5169 parse_oacc_loop (gfc_statement acc_st
)
5173 gfc_state_data s
, *sd
;
5175 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
5176 if (sd
->state
== COMP_CRITICAL
)
5177 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5179 accept_statement (acc_st
);
5181 cp
= gfc_state_stack
->tail
;
5182 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5183 np
= new_level (cp
);
5189 st
= next_statement ();
5192 else if (st
== ST_DO
)
5196 gfc_error ("Expected DO loop at %C");
5197 reject_statement ();
5202 if (gfc_statement_label
!= NULL
5203 && gfc_state_stack
->previous
!= NULL
5204 && gfc_state_stack
->previous
->state
== COMP_DO
5205 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
5208 return ST_IMPLIED_ENDDO
;
5211 check_do_closure ();
5214 st
= next_statement ();
5215 if (st
== ST_OACC_END_LOOP
)
5216 gfc_warning (0, "Redundant !$ACC END LOOP at %C");
5217 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
5218 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
5219 (acc_st
== ST_OACC_SERIAL_LOOP
&& st
== ST_OACC_END_SERIAL_LOOP
) ||
5220 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
5222 gcc_assert (new_st
.op
== EXEC_NOP
);
5223 gfc_clear_new_st ();
5224 gfc_commit_symbols ();
5225 gfc_warning_check ();
5226 st
= next_statement ();
5232 /* Parse the statements of an OpenMP structured block. */
5235 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
5237 gfc_statement st
, omp_end_st
;
5241 accept_statement (omp_st
);
5243 cp
= gfc_state_stack
->tail
;
5244 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5245 np
= new_level (cp
);
5251 case ST_OMP_PARALLEL
:
5252 omp_end_st
= ST_OMP_END_PARALLEL
;
5254 case ST_OMP_PARALLEL_SECTIONS
:
5255 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
5257 case ST_OMP_SECTIONS
:
5258 omp_end_st
= ST_OMP_END_SECTIONS
;
5260 case ST_OMP_ORDERED
:
5261 omp_end_st
= ST_OMP_END_ORDERED
;
5263 case ST_OMP_CRITICAL
:
5264 omp_end_st
= ST_OMP_END_CRITICAL
;
5267 omp_end_st
= ST_OMP_END_MASTER
;
5270 omp_end_st
= ST_OMP_END_SINGLE
;
5273 omp_end_st
= ST_OMP_END_TARGET
;
5275 case ST_OMP_TARGET_DATA
:
5276 omp_end_st
= ST_OMP_END_TARGET_DATA
;
5278 case ST_OMP_TARGET_PARALLEL
:
5279 omp_end_st
= ST_OMP_END_TARGET_PARALLEL
;
5281 case ST_OMP_TARGET_TEAMS
:
5282 omp_end_st
= ST_OMP_END_TARGET_TEAMS
;
5284 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5285 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
5287 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5288 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5290 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5291 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5293 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5294 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
5297 omp_end_st
= ST_OMP_END_TASK
;
5299 case ST_OMP_TASKGROUP
:
5300 omp_end_st
= ST_OMP_END_TASKGROUP
;
5303 omp_end_st
= ST_OMP_END_TEAMS
;
5305 case ST_OMP_TEAMS_DISTRIBUTE
:
5306 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
5308 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5309 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5311 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5312 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5314 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5315 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
5317 case ST_OMP_DISTRIBUTE
:
5318 omp_end_st
= ST_OMP_END_DISTRIBUTE
;
5320 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5321 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
5323 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5324 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
5326 case ST_OMP_DISTRIBUTE_SIMD
:
5327 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
5329 case ST_OMP_WORKSHARE
:
5330 omp_end_st
= ST_OMP_END_WORKSHARE
;
5332 case ST_OMP_PARALLEL_WORKSHARE
:
5333 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
5341 if (workshare_stmts_only
)
5343 /* Inside of !$omp workshare, only
5346 where statements and constructs
5347 forall statements and constructs
5351 are allowed. For !$omp critical these
5352 restrictions apply recursively. */
5355 st
= next_statement ();
5366 accept_statement (st
);
5369 case ST_WHERE_BLOCK
:
5370 parse_where_block ();
5373 case ST_FORALL_BLOCK
:
5374 parse_forall_block ();
5377 case ST_OMP_PARALLEL
:
5378 case ST_OMP_PARALLEL_SECTIONS
:
5379 parse_omp_structured_block (st
, false);
5382 case ST_OMP_PARALLEL_WORKSHARE
:
5383 case ST_OMP_CRITICAL
:
5384 parse_omp_structured_block (st
, true);
5387 case ST_OMP_PARALLEL_DO
:
5388 case ST_OMP_PARALLEL_DO_SIMD
:
5389 st
= parse_omp_do (st
);
5393 st
= parse_omp_oacc_atomic (true);
5404 st
= next_statement ();
5408 st
= parse_executable (ST_NONE
);
5411 else if (st
== ST_OMP_SECTION
5412 && (omp_st
== ST_OMP_SECTIONS
5413 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
5415 np
= new_level (np
);
5419 else if (st
!= omp_end_st
)
5420 unexpected_statement (st
);
5422 while (st
!= omp_end_st
);
5426 case EXEC_OMP_END_NOWAIT
:
5427 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
5429 case EXEC_OMP_END_CRITICAL
:
5430 if (((cp
->ext
.omp_clauses
->critical_name
== NULL
)
5431 ^ (new_st
.ext
.omp_name
== NULL
))
5432 || (new_st
.ext
.omp_name
!= NULL
5433 && strcmp (cp
->ext
.omp_clauses
->critical_name
,
5434 new_st
.ext
.omp_name
) != 0))
5435 gfc_error ("Name after !$omp critical and !$omp end critical does "
5437 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
5438 new_st
.ext
.omp_name
= NULL
;
5440 case EXEC_OMP_END_SINGLE
:
5441 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
5442 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
5443 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
5444 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
5452 gfc_clear_new_st ();
5453 gfc_commit_symbols ();
5454 gfc_warning_check ();
5459 /* Accept a series of executable statements. We return the first
5460 statement that doesn't fit to the caller. Any block statements are
5461 passed on to the correct handler, which usually passes the buck
5464 static gfc_statement
5465 parse_executable (gfc_statement st
)
5470 st
= next_statement ();
5474 close_flag
= check_do_closure ();
5479 case ST_END_PROGRAM
:
5482 case ST_END_FUNCTION
:
5487 case ST_END_SUBROUTINE
:
5492 case ST_SELECT_CASE
:
5493 gfc_error ("%s statement at %C cannot terminate a non-block "
5494 "DO loop", gfc_ascii_statement (st
));
5507 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
5508 "first executable statement");
5514 accept_statement (st
);
5515 if (close_flag
== 1)
5516 return ST_IMPLIED_ENDDO
;
5520 parse_block_construct ();
5531 case ST_SELECT_CASE
:
5532 parse_select_block ();
5535 case ST_SELECT_TYPE
:
5536 parse_select_type_block ();
5539 case ST_SELECT_RANK
:
5540 parse_select_rank_block ();
5545 if (check_do_closure () == 1)
5546 return ST_IMPLIED_ENDDO
;
5550 parse_critical_block ();
5553 case ST_WHERE_BLOCK
:
5554 parse_where_block ();
5557 case ST_FORALL_BLOCK
:
5558 parse_forall_block ();
5561 case ST_OACC_PARALLEL_LOOP
:
5562 case ST_OACC_KERNELS_LOOP
:
5563 case ST_OACC_SERIAL_LOOP
:
5565 st
= parse_oacc_loop (st
);
5566 if (st
== ST_IMPLIED_ENDDO
)
5570 case ST_OACC_PARALLEL
:
5571 case ST_OACC_KERNELS
:
5572 case ST_OACC_SERIAL
:
5574 case ST_OACC_HOST_DATA
:
5575 parse_oacc_structured_block (st
);
5578 case ST_OMP_PARALLEL
:
5579 case ST_OMP_PARALLEL_SECTIONS
:
5580 case ST_OMP_SECTIONS
:
5581 case ST_OMP_ORDERED
:
5582 case ST_OMP_CRITICAL
:
5586 case ST_OMP_TARGET_DATA
:
5587 case ST_OMP_TARGET_PARALLEL
:
5588 case ST_OMP_TARGET_TEAMS
:
5591 case ST_OMP_TASKGROUP
:
5592 parse_omp_structured_block (st
, false);
5595 case ST_OMP_WORKSHARE
:
5596 case ST_OMP_PARALLEL_WORKSHARE
:
5597 parse_omp_structured_block (st
, true);
5600 case ST_OMP_DISTRIBUTE
:
5601 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5602 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5603 case ST_OMP_DISTRIBUTE_SIMD
:
5605 case ST_OMP_DO_SIMD
:
5606 case ST_OMP_PARALLEL_DO
:
5607 case ST_OMP_PARALLEL_DO_SIMD
:
5609 case ST_OMP_TARGET_PARALLEL_DO
:
5610 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
5611 case ST_OMP_TARGET_SIMD
:
5612 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5613 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5614 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5615 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5616 case ST_OMP_TASKLOOP
:
5617 case ST_OMP_TASKLOOP_SIMD
:
5618 case ST_OMP_TEAMS_DISTRIBUTE
:
5619 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5620 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5621 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5622 st
= parse_omp_do (st
);
5623 if (st
== ST_IMPLIED_ENDDO
)
5627 case ST_OACC_ATOMIC
:
5628 st
= parse_omp_oacc_atomic (false);
5632 st
= parse_omp_oacc_atomic (true);
5639 if (directive_unroll
!= -1)
5640 gfc_error ("%<GCC unroll%> directive not at the start of a loop at %C");
5642 if (directive_ivdep
)
5643 gfc_error ("%<GCC ivdep%> directive not at the start of a loop at %C");
5645 if (directive_vector
)
5646 gfc_error ("%<GCC vector%> directive not at the start of a loop at %C");
5648 if (directive_novector
)
5649 gfc_error ("%<GCC novector%> "
5650 "directive not at the start of a loop at %C");
5652 st
= next_statement ();
5657 /* Fix the symbols for sibling functions. These are incorrectly added to
5658 the child namespace as the parser didn't know about this procedure. */
5661 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
5665 gfc_symbol
*old_sym
;
5667 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
5669 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
5671 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
5672 goto fixup_contained
;
5674 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
5675 && sym
->attr
.generic
&& sym
->attr
.function
)
5676 ||(sym
->attr
.flavor
== FL_DERIVED
5677 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
5678 goto fixup_contained
;
5680 old_sym
= st
->n
.sym
;
5681 if (old_sym
->ns
== ns
5682 && !old_sym
->attr
.contained
5684 /* By 14.6.1.3, host association should be excluded
5685 for the following. */
5686 && !(old_sym
->attr
.external
5687 || (old_sym
->ts
.type
!= BT_UNKNOWN
5688 && !old_sym
->attr
.implicit_type
)
5689 || old_sym
->attr
.flavor
== FL_PARAMETER
5690 || old_sym
->attr
.use_assoc
5691 || old_sym
->attr
.in_common
5692 || old_sym
->attr
.in_equivalence
5693 || old_sym
->attr
.data
5694 || old_sym
->attr
.dummy
5695 || old_sym
->attr
.result
5696 || old_sym
->attr
.dimension
5697 || old_sym
->attr
.allocatable
5698 || old_sym
->attr
.intrinsic
5699 || old_sym
->attr
.generic
5700 || old_sym
->attr
.flavor
== FL_NAMELIST
5701 || old_sym
->attr
.flavor
== FL_LABEL
5702 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
5704 /* Replace it with the symbol from the parent namespace. */
5708 gfc_release_symbol (old_sym
);
5712 /* Do the same for any contained procedures. */
5713 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
5718 parse_contained (int module
)
5720 gfc_namespace
*ns
, *parent_ns
, *tmp
;
5721 gfc_state_data s1
, s2
;
5726 int contains_statements
= 0;
5729 push_state (&s1
, COMP_CONTAINS
, NULL
);
5730 parent_ns
= gfc_current_ns
;
5734 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
5736 gfc_current_ns
->sibling
= parent_ns
->contained
;
5737 parent_ns
->contained
= gfc_current_ns
;
5740 /* Process the next available statement. We come here if we got an error
5741 and rejected the last statement. */
5742 old_loc
= gfc_current_locus
;
5743 st
= next_statement ();
5752 contains_statements
= 1;
5753 accept_statement (st
);
5756 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
5759 /* For internal procedures, create/update the symbol in the
5760 parent namespace. */
5764 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
5765 gfc_error ("Contained procedure %qs at %C is already "
5766 "ambiguous", gfc_new_block
->name
);
5769 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
5771 &gfc_new_block
->declared_at
))
5773 if (st
== ST_FUNCTION
)
5774 gfc_add_function (&sym
->attr
, sym
->name
,
5775 &gfc_new_block
->declared_at
);
5777 gfc_add_subroutine (&sym
->attr
, sym
->name
,
5778 &gfc_new_block
->declared_at
);
5782 gfc_commit_symbols ();
5785 sym
= gfc_new_block
;
5787 /* Mark this as a contained function, so it isn't replaced
5788 by other module functions. */
5789 sym
->attr
.contained
= 1;
5791 /* Set implicit_pure so that it can be reset if any of the
5792 tests for purity fail. This is used for some optimisation
5793 during translation. */
5794 if (!sym
->attr
.pure
)
5795 sym
->attr
.implicit_pure
= 1;
5797 parse_progunit (ST_NONE
);
5799 /* Fix up any sibling functions that refer to this one. */
5800 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
5801 /* Or refer to any of its alternate entry points. */
5802 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
5803 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
5805 gfc_current_ns
->code
= s2
.head
;
5806 gfc_current_ns
= parent_ns
;
5811 /* These statements are associated with the end of the host unit. */
5812 case ST_END_FUNCTION
:
5814 case ST_END_SUBMODULE
:
5815 case ST_END_PROGRAM
:
5816 case ST_END_SUBROUTINE
:
5817 accept_statement (st
);
5818 gfc_current_ns
->code
= s1
.head
;
5822 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
5823 gfc_ascii_statement (st
));
5824 reject_statement ();
5830 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
5831 && st
!= ST_END_MODULE
&& st
!= ST_END_SUBMODULE
5832 && st
!= ST_END_PROGRAM
);
5834 /* The first namespace in the list is guaranteed to not have
5835 anything (worthwhile) in it. */
5836 tmp
= gfc_current_ns
;
5837 gfc_current_ns
= parent_ns
;
5838 if (seen_error
&& tmp
->refs
> 1)
5839 gfc_free_namespace (tmp
);
5841 ns
= gfc_current_ns
->contained
;
5842 gfc_current_ns
->contained
= ns
->sibling
;
5843 gfc_free_namespace (ns
);
5846 if (!contains_statements
)
5847 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
5848 "FUNCTION or SUBROUTINE statement at %L", &old_loc
);
5852 /* The result variable in a MODULE PROCEDURE needs to be created and
5853 its characteristics copied from the interface since it is neither
5854 declared in the procedure declaration nor in the specification
5858 get_modproc_result (void)
5861 if (gfc_state_stack
->previous
5862 && gfc_state_stack
->previous
->state
== COMP_CONTAINS
5863 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
5865 proc
= gfc_current_ns
->proc_name
? gfc_current_ns
->proc_name
: NULL
;
5867 && proc
->attr
.function
5869 && proc
->tlink
->result
5870 && proc
->tlink
->result
!= proc
->tlink
)
5872 gfc_copy_dummy_sym (&proc
->result
, proc
->tlink
->result
, 1);
5873 gfc_set_sym_referenced (proc
->result
);
5874 proc
->result
->attr
.if_source
= IFSRC_DECL
;
5875 gfc_commit_symbol (proc
->result
);
5881 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
5884 parse_progunit (gfc_statement st
)
5889 gfc_adjust_builtins ();
5892 && gfc_new_block
->abr_modproc_decl
5893 && gfc_new_block
->attr
.function
)
5894 get_modproc_result ();
5896 st
= parse_spec (st
);
5903 /* This is not allowed within BLOCK! */
5904 if (gfc_current_state () != COMP_BLOCK
)
5909 accept_statement (st
);
5916 if (gfc_current_state () == COMP_FUNCTION
)
5917 gfc_check_function_type (gfc_current_ns
);
5922 st
= parse_executable (st
);
5930 /* This is not allowed within BLOCK! */
5931 if (gfc_current_state () != COMP_BLOCK
)
5936 accept_statement (st
);
5943 unexpected_statement (st
);
5944 reject_statement ();
5945 st
= next_statement ();
5951 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
5952 if (p
->state
== COMP_CONTAINS
)
5955 if (gfc_find_state (COMP_MODULE
) == true
5956 || gfc_find_state (COMP_SUBMODULE
) == true)
5961 gfc_error ("CONTAINS statement at %C is already in a contained "
5963 reject_statement ();
5964 st
= next_statement ();
5968 parse_contained (0);
5971 gfc_current_ns
->code
= gfc_state_stack
->head
;
5975 /* Come here to complain about a global symbol already in use as
5979 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
5984 where
= &gfc_current_locus
;
5994 case GSYM_SUBROUTINE
:
5995 name
= "SUBROUTINE";
6000 case GSYM_BLOCK_DATA
:
6001 name
= "BLOCK DATA";
6012 if (sym
->binding_label
)
6013 gfc_error ("Global binding name %qs at %L is already being used "
6014 "as a %s at %L", sym
->binding_label
, where
, name
,
6017 gfc_error ("Global name %qs at %L is already being used as "
6018 "a %s at %L", sym
->name
, where
, name
, &sym
->where
);
6022 if (sym
->binding_label
)
6023 gfc_error ("Global binding name %qs at %L is already being used "
6024 "at %L", sym
->binding_label
, where
, &sym
->where
);
6026 gfc_error ("Global name %qs at %L is already being used at %L",
6027 sym
->name
, where
, &sym
->where
);
6032 /* Parse a block data program unit. */
6035 parse_block_data (void)
6038 static locus blank_locus
;
6039 static int blank_block
=0;
6042 gfc_current_ns
->proc_name
= gfc_new_block
;
6043 gfc_current_ns
->is_block_data
= 1;
6045 if (gfc_new_block
== NULL
)
6048 gfc_error ("Blank BLOCK DATA at %C conflicts with "
6049 "prior BLOCK DATA at %L", &blank_locus
);
6053 blank_locus
= gfc_current_locus
;
6058 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6060 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
6061 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6064 s
->type
= GSYM_BLOCK_DATA
;
6065 s
->where
= gfc_new_block
->declared_at
;
6070 st
= parse_spec (ST_NONE
);
6072 while (st
!= ST_END_BLOCK_DATA
)
6074 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
6075 gfc_ascii_statement (st
));
6076 reject_statement ();
6077 st
= next_statement ();
6082 /* Following the association of the ancestor (sub)module symbols, they
6083 must be set host rather than use associated and all must be public.
6084 They are flagged up by 'used_in_submodule' so that they can be set
6085 DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
6086 linker chokes on multiple symbol definitions. */
6089 set_syms_host_assoc (gfc_symbol
*sym
)
6092 const char dot
[2] = ".";
6093 /* Symbols take the form module.submodule_ or module.name_. */
6094 char parent1
[2 * GFC_MAX_SYMBOL_LEN
+ 2];
6095 char parent2
[2 * GFC_MAX_SYMBOL_LEN
+ 2];
6100 if (sym
->attr
.module_procedure
)
6101 sym
->attr
.external
= 0;
6103 sym
->attr
.use_assoc
= 0;
6104 sym
->attr
.host_assoc
= 1;
6105 sym
->attr
.used_in_submodule
=1;
6107 if (sym
->attr
.flavor
== FL_DERIVED
)
6109 /* Derived types with PRIVATE components that are declared in
6110 modules other than the parent module must not be changed to be
6111 PUBLIC. The 'use-assoc' attribute must be reset so that the
6112 test in symbol.c(gfc_find_component) works correctly. This is
6113 not necessary for PRIVATE symbols since they are not read from
6115 memset(parent1
, '\0', sizeof(parent1
));
6116 memset(parent2
, '\0', sizeof(parent2
));
6117 strcpy (parent1
, gfc_new_block
->name
);
6118 strcpy (parent2
, sym
->module
);
6119 if (strcmp (strtok (parent1
, dot
), strtok (parent2
, dot
)) == 0)
6121 for (c
= sym
->components
; c
; c
= c
->next
)
6122 c
->attr
.access
= ACCESS_PUBLIC
;
6126 sym
->attr
.use_assoc
= 1;
6127 sym
->attr
.host_assoc
= 0;
6132 /* Parse a module subprogram. */
6141 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6142 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
6143 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6146 s
->type
= GSYM_MODULE
;
6147 s
->where
= gfc_new_block
->declared_at
;
6151 /* Something is nulling the module_list after this point. This is good
6152 since it allows us to 'USE' the parent modules that the submodule
6153 inherits and to set (most) of the symbols as host associated. */
6154 if (gfc_current_state () == COMP_SUBMODULE
)
6157 gfc_traverse_ns (gfc_current_ns
, set_syms_host_assoc
);
6160 st
= parse_spec (ST_NONE
);
6170 parse_contained (1);
6174 case ST_END_SUBMODULE
:
6175 accept_statement (st
);
6179 gfc_error ("Unexpected %s statement in MODULE at %C",
6180 gfc_ascii_statement (st
));
6183 reject_statement ();
6184 st
= next_statement ();
6188 /* Make sure not to free the namespace twice on error. */
6190 s
->ns
= gfc_current_ns
;
6194 /* Add a procedure name to the global symbol table. */
6197 add_global_procedure (bool sub
)
6201 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6202 name is a global identifier. */
6203 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
6205 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6208 || (s
->type
!= GSYM_UNKNOWN
6209 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
6211 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6212 /* Silence follow-up errors. */
6213 gfc_new_block
->binding_label
= NULL
;
6217 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6218 s
->sym_name
= gfc_new_block
->name
;
6219 s
->where
= gfc_new_block
->declared_at
;
6221 s
->ns
= gfc_current_ns
;
6225 /* Don't add the symbol multiple times. */
6226 if (gfc_new_block
->binding_label
6227 && (!gfc_notification_std (GFC_STD_F2008
)
6228 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
6230 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
, true);
6233 || (s
->type
!= GSYM_UNKNOWN
6234 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
6236 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6237 /* Silence follow-up errors. */
6238 gfc_new_block
->binding_label
= NULL
;
6242 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6243 s
->sym_name
= gfc_new_block
->name
;
6244 s
->binding_label
= gfc_new_block
->binding_label
;
6245 s
->where
= gfc_new_block
->declared_at
;
6247 s
->ns
= gfc_current_ns
;
6253 /* Add a program to the global symbol table. */
6256 add_global_program (void)
6260 if (gfc_new_block
== NULL
)
6262 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6264 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
6265 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6268 s
->type
= GSYM_PROGRAM
;
6269 s
->where
= gfc_new_block
->declared_at
;
6271 s
->ns
= gfc_current_ns
;
6276 /* Resolve all the program units. */
6278 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
6280 gfc_derived_types
= NULL
;
6281 gfc_current_ns
= gfc_global_ns_list
;
6282 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6284 if (gfc_current_ns
->proc_name
6285 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6286 continue; /* Already resolved. */
6288 if (gfc_current_ns
->proc_name
)
6289 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6290 gfc_resolve (gfc_current_ns
);
6291 gfc_current_ns
->derived_types
= gfc_derived_types
;
6292 gfc_derived_types
= NULL
;
6298 clean_up_modules (gfc_gsymbol
*gsym
)
6303 clean_up_modules (gsym
->left
);
6304 clean_up_modules (gsym
->right
);
6306 if (gsym
->type
!= GSYM_MODULE
|| !gsym
->ns
)
6309 gfc_current_ns
= gsym
->ns
;
6310 gfc_derived_types
= gfc_current_ns
->derived_types
;
6317 /* Translate all the program units. This could be in a different order
6318 to resolution if there are forward references in the file. */
6320 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
6324 gfc_current_ns
= gfc_global_ns_list
;
6325 gfc_get_errors (NULL
, &errors
);
6327 /* We first translate all modules to make sure that later parts
6328 of the program can use the decl. Then we translate the nonmodules. */
6330 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6332 if (!gfc_current_ns
->proc_name
6333 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6336 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6337 gfc_derived_types
= gfc_current_ns
->derived_types
;
6338 gfc_generate_module_code (gfc_current_ns
);
6339 gfc_current_ns
->translated
= 1;
6342 gfc_current_ns
= gfc_global_ns_list
;
6343 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6345 if (gfc_current_ns
->proc_name
6346 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6349 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6350 gfc_derived_types
= gfc_current_ns
->derived_types
;
6351 gfc_generate_code (gfc_current_ns
);
6352 gfc_current_ns
->translated
= 1;
6355 /* Clean up all the namespaces after translation. */
6356 gfc_current_ns
= gfc_global_ns_list
;
6357 for (;gfc_current_ns
;)
6361 if (gfc_current_ns
->proc_name
6362 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6364 gfc_current_ns
= gfc_current_ns
->sibling
;
6368 ns
= gfc_current_ns
->sibling
;
6369 gfc_derived_types
= gfc_current_ns
->derived_types
;
6371 gfc_current_ns
= ns
;
6374 clean_up_modules (gfc_gsym_root
);
6378 /* Top level parser. */
6381 gfc_parse_file (void)
6383 int seen_program
, errors_before
, errors
;
6384 gfc_state_data top
, s
;
6387 gfc_namespace
*next
;
6389 gfc_start_source_files ();
6391 top
.state
= COMP_NONE
;
6393 top
.previous
= NULL
;
6394 top
.head
= top
.tail
= NULL
;
6395 top
.do_variable
= NULL
;
6397 gfc_state_stack
= &top
;
6399 gfc_clear_new_st ();
6401 gfc_statement_label
= NULL
;
6403 if (setjmp (eof_buf
))
6404 return false; /* Come here on unexpected EOF */
6406 /* Prepare the global namespace that will contain the
6408 gfc_global_ns_list
= next
= NULL
;
6413 /* Exit early for empty files. */
6417 in_specification_block
= true;
6420 st
= next_statement ();
6429 goto duplicate_main
;
6431 prog_locus
= gfc_current_locus
;
6433 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
6434 main_program_symbol (gfc_current_ns
, gfc_new_block
->name
);
6435 accept_statement (st
);
6436 add_global_program ();
6437 parse_progunit (ST_NONE
);
6441 add_global_procedure (true);
6442 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
6443 accept_statement (st
);
6444 parse_progunit (ST_NONE
);
6448 add_global_procedure (false);
6449 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
6450 accept_statement (st
);
6451 parse_progunit (ST_NONE
);
6455 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
6456 accept_statement (st
);
6457 parse_block_data ();
6461 push_state (&s
, COMP_MODULE
, gfc_new_block
);
6462 accept_statement (st
);
6464 gfc_get_errors (NULL
, &errors_before
);
6469 push_state (&s
, COMP_SUBMODULE
, gfc_new_block
);
6470 accept_statement (st
);
6472 gfc_get_errors (NULL
, &errors_before
);
6476 /* Anything else starts a nameless main program block. */
6479 goto duplicate_main
;
6481 prog_locus
= gfc_current_locus
;
6483 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
6484 main_program_symbol (gfc_current_ns
, "MAIN__");
6485 parse_progunit (st
);
6489 /* Handle the non-program units. */
6490 gfc_current_ns
->code
= s
.head
;
6492 gfc_resolve (gfc_current_ns
);
6494 /* Fix the implicit_pure attribute for those procedures who should
6496 while (gfc_fix_implicit_pure (gfc_current_ns
))
6499 /* Dump the parse tree if requested. */
6500 if (flag_dump_fortran_original
)
6501 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6503 gfc_get_errors (NULL
, &errors
);
6504 if (s
.state
== COMP_MODULE
|| s
.state
== COMP_SUBMODULE
)
6506 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
6507 gfc_current_ns
->derived_types
= gfc_derived_types
;
6508 gfc_derived_types
= NULL
;
6514 gfc_generate_code (gfc_current_ns
);
6522 /* The main program and non-contained procedures are put
6523 in the global namespace list, so that they can be processed
6524 later and all their interfaces resolved. */
6525 gfc_current_ns
->code
= s
.head
;
6528 for (; next
->sibling
; next
= next
->sibling
)
6530 next
->sibling
= gfc_current_ns
;
6533 gfc_global_ns_list
= gfc_current_ns
;
6535 next
= gfc_current_ns
;
6541 /* Do the resolution. */
6542 resolve_all_program_units (gfc_global_ns_list
);
6544 /* Go through all top-level namespaces and unset the implicit_pure
6545 attribute for any procedures that call something not pure or
6546 implicit_pure. Because the a procedure marked as not implicit_pure
6547 in one sweep may be called by another routine, we repeat this
6548 process until there are no more changes. */
6553 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
6554 gfc_current_ns
= gfc_current_ns
->sibling
)
6556 if (gfc_fix_implicit_pure (gfc_current_ns
))
6562 /* Fixup for external procedures and resolve 'omp requires'. */
6565 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
6566 gfc_current_ns
= gfc_current_ns
->sibling
)
6568 omp_requires
|= gfc_current_ns
->omp_requires
;
6569 gfc_check_externals (gfc_current_ns
);
6571 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
6572 gfc_current_ns
= gfc_current_ns
->sibling
)
6573 gfc_check_omp_requires (gfc_current_ns
, omp_requires
);
6575 /* Do the parse tree dump. */
6576 gfc_current_ns
= flag_dump_fortran_original
? gfc_global_ns_list
: NULL
;
6578 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6579 if (!gfc_current_ns
->proc_name
6580 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
6582 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
6583 fputs ("------------------------------------------\n\n", stdout
);
6586 /* Dump C prototypes. */
6587 if (flag_c_prototypes
|| flag_c_prototypes_external
)
6590 "#include <stddef.h>\n"
6591 "#ifdef __cplusplus\n"
6592 "#include <complex>\n"
6593 "#define __GFORTRAN_FLOAT_COMPLEX std::complex<float>\n"
6594 "#define __GFORTRAN_DOUBLE_COMPLEX std::complex<double>\n"
6595 "#define __GFORTRAN_LONG_DOUBLE_COMPLEX std::complex<long double>\n"
6598 "#define __GFORTRAN_FLOAT_COMPLEX float _Complex\n"
6599 "#define __GFORTRAN_DOUBLE_COMPLEX double _Complex\n"
6600 "#define __GFORTRAN_LONG_DOUBLE_COMPLEX long double _Complex\n"
6604 /* First dump BIND(C) prototypes. */
6605 if (flag_c_prototypes
)
6607 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
6608 gfc_current_ns
= gfc_current_ns
->sibling
)
6609 gfc_dump_c_prototypes (gfc_current_ns
, stdout
);
6612 /* Dump external prototypes. */
6613 if (flag_c_prototypes_external
)
6614 gfc_dump_external_c_prototypes (stdout
);
6616 if (flag_c_prototypes
|| flag_c_prototypes_external
)
6617 fprintf (stdout
, "\n#ifdef __cplusplus\n}\n#endif\n");
6619 /* Do the translation. */
6620 translate_all_program_units (gfc_global_ns_list
);
6622 /* Dump the global symbol ist. We only do this here because part
6623 of it is generated after mangling the identifiers in
6626 if (flag_dump_fortran_global
)
6627 gfc_dump_global_symbols (stdout
);
6629 gfc_end_source_files ();
6633 /* If we see a duplicate main program, shut down. If the second
6634 instance is an implied main program, i.e. data decls or executable
6635 statements, we're in for lots of errors. */
6636 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
6637 reject_statement ();
6642 /* Return true if this state data represents an OpenACC region. */
6644 is_oacc (gfc_state_data
*sd
)
6646 switch (sd
->construct
->op
)
6648 case EXEC_OACC_PARALLEL_LOOP
:
6649 case EXEC_OACC_PARALLEL
:
6650 case EXEC_OACC_KERNELS_LOOP
:
6651 case EXEC_OACC_KERNELS
:
6652 case EXEC_OACC_SERIAL_LOOP
:
6653 case EXEC_OACC_SERIAL
:
6654 case EXEC_OACC_DATA
:
6655 case EXEC_OACC_HOST_DATA
:
6656 case EXEC_OACC_LOOP
:
6657 case EXEC_OACC_UPDATE
:
6658 case EXEC_OACC_WAIT
:
6659 case EXEC_OACC_CACHE
:
6660 case EXEC_OACC_ENTER_DATA
:
6661 case EXEC_OACC_EXIT_DATA
:
6662 case EXEC_OACC_ATOMIC
:
6663 case EXEC_OACC_ROUTINE
: