2 Copyright (C) 2000-2023 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"
29 #include "tree-core.h"
30 #include "omp-general.h"
32 /* Current statement label. Zero means no statement label. Because new_st
33 can get wiped during statement matching, we have to keep it separate. */
35 gfc_st_label
*gfc_statement_label
;
37 static locus label_locus
;
38 static jmp_buf eof_buf
;
40 /* Respectively pointer and content of the current interface body being parsed
41 as they were at the beginning of decode_statement. Used to restore the
42 interface to its previous state in case a parsed statement is rejected after
43 some symbols have been added to the interface. */
44 static gfc_interface
**current_interface_ptr
= nullptr;
45 static gfc_interface
*previous_interface_head
= nullptr;
47 gfc_state_data
*gfc_state_stack
;
48 static bool last_was_use_stmt
= false;
51 /* TODO: Re-order functions to kill these forward decls. */
52 static void check_statement_label (gfc_statement
);
53 static void undo_new_statement (void);
54 static void reject_statement (void);
57 /* A sort of half-matching function. We try to match the word on the
58 input with the passed string. If this succeeds, we call the
59 keyword-dependent matching function that will match the rest of the
60 statement. For single keywords, the matching subroutine is
64 match_word (const char *str
, match (*subr
) (void), locus
*old_locus
)
79 gfc_current_locus
= *old_locus
;
87 /* Like match_word, but if str is matched, set a flag that it
90 match_word_omp_simd (const char *str
, match (*subr
) (void), locus
*old_locus
,
100 *simd_matched
= true;
107 gfc_current_locus
= *old_locus
;
115 /* Load symbols from all USE statements encountered in this scoping unit. */
120 gfc_error_buffer old_error
;
122 gfc_push_error (&old_error
);
123 gfc_buffer_error (false);
125 gfc_buffer_error (true);
126 gfc_pop_error (&old_error
);
127 gfc_commit_symbols ();
128 gfc_warning_check ();
129 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
130 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
131 last_was_use_stmt
= false;
135 /* Figure out what the next statement is, (mostly) regardless of
136 proper ordering. The do...while(0) is there to prevent if/else
139 #define match(keyword, subr, st) \
141 if (match_word (keyword, subr, &old_locus) == MATCH_YES) \
144 undo_new_statement (); \
148 /* This is a specialist version of decode_statement that is used
149 for the specification statements in a function, whose
150 characteristics are deferred into the specification statements.
151 eg.: INTEGER (king = mykind) foo ()
152 USE mymodule, ONLY mykind.....
153 The KIND parameter needs a return after USE or IMPORT, whereas
154 derived type declarations can occur anywhere, up the executable
155 block. ST_GET_FCN_CHARACTERISTICS is returned when we have run
156 out of the correct kind of specification statements. */
158 decode_specification_statement (void)
164 if (gfc_match_eos () == MATCH_YES
)
167 old_locus
= gfc_current_locus
;
169 if (match_word ("use", gfc_match_use
, &old_locus
) == MATCH_YES
)
171 last_was_use_stmt
= true;
176 undo_new_statement ();
177 if (last_was_use_stmt
)
181 match ("import", gfc_match_import
, ST_IMPORT
);
183 if (gfc_current_block ()->result
->ts
.type
!= BT_DERIVED
)
186 match (NULL
, gfc_match_st_function
, ST_STATEMENT_FUNCTION
);
187 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
188 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
190 /* General statement matching: Instead of testing every possible
191 statement, we eliminate most possibilities by peeking at the
194 c
= gfc_peek_ascii_char ();
199 match ("abstract% interface", gfc_match_abstract_interface
,
201 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
202 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
203 match ("automatic", gfc_match_automatic
, ST_ATTR_DECL
);
207 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
211 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
212 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
216 match ("data", gfc_match_data
, ST_DATA
);
217 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
221 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
222 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
223 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
224 match ("external", gfc_match_external
, ST_ATTR_DECL
);
228 match ("format", gfc_match_format
, ST_FORMAT
);
235 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
236 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
237 match ("interface", gfc_match_interface
, ST_INTERFACE
);
238 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
239 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
246 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
250 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
254 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
255 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
256 if (gfc_match_private (&st
) == MATCH_YES
)
258 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
259 if (gfc_match_public (&st
) == MATCH_YES
)
261 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
268 match ("save", gfc_match_save
, ST_ATTR_DECL
);
269 match ("static", gfc_match_static
, ST_ATTR_DECL
);
270 match ("structure", gfc_match_structure_decl
, ST_STRUCTURE_DECL
);
274 match ("target", gfc_match_target
, ST_ATTR_DECL
);
275 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
282 match ("value", gfc_match_value
, ST_ATTR_DECL
);
283 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
290 /* This is not a specification statement. See if any of the matchers
291 has stored an error message of some sort. */
295 gfc_buffer_error (false);
296 gfc_current_locus
= old_locus
;
298 return ST_GET_FCN_CHARACTERISTICS
;
302 /* Tells whether gfc_get_current_interface_head can be used safely. */
305 current_interface_valid_p ()
307 switch (current_interface
.type
)
309 case INTERFACE_INTRINSIC_OP
:
310 return current_interface
.ns
!= nullptr;
312 case INTERFACE_GENERIC
:
314 return current_interface
.sym
!= nullptr;
316 case INTERFACE_USER_OP
:
317 return current_interface
.uop
!= nullptr;
325 /* Return a pointer to the interface currently being parsed, or nullptr if
326 we are not currently parsing an interface body. */
328 static gfc_interface
**
329 get_current_interface_ptr ()
331 if (current_interface_valid_p ())
333 gfc_interface
*& ifc_ptr
= gfc_current_interface_head ();
341 static bool in_specification_block
;
343 /* This is the primary 'decode_statement'. */
345 decode_statement (void)
352 gfc_enforce_clean_symbol_state ();
354 gfc_clear_error (); /* Clear any pending errors. */
355 gfc_clear_warning (); /* Clear any pending warnings. */
357 current_interface_ptr
= get_current_interface_ptr ();
358 previous_interface_head
= current_interface_ptr
== nullptr
360 : *current_interface_ptr
;
362 gfc_matching_function
= false;
364 if (gfc_match_eos () == MATCH_YES
)
367 if (gfc_current_state () == COMP_FUNCTION
368 && gfc_current_block ()->result
->ts
.kind
== -1)
369 return decode_specification_statement ();
371 old_locus
= gfc_current_locus
;
373 c
= gfc_peek_ascii_char ();
377 if (match_word ("use", gfc_match_use
, &old_locus
) == MATCH_YES
)
379 last_was_use_stmt
= true;
383 undo_new_statement ();
386 if (last_was_use_stmt
)
389 /* Try matching a data declaration or function declaration. The
390 input "REALFUNCTIONA(N)" can mean several things in different
391 contexts, so it (and its relatives) get special treatment. */
393 if (gfc_current_state () == COMP_NONE
394 || gfc_current_state () == COMP_INTERFACE
395 || gfc_current_state () == COMP_CONTAINS
)
397 gfc_matching_function
= true;
398 m
= gfc_match_function_decl ();
401 else if (m
== MATCH_ERROR
)
405 gfc_current_locus
= old_locus
;
407 gfc_matching_function
= false;
409 /* Legacy parameter statements are ambiguous with assignments so try parameter
411 match ("parameter", gfc_match_parameter
, ST_PARAMETER
);
413 /* Match statements whose error messages are meant to be overwritten
414 by something better. */
416 match (NULL
, gfc_match_assignment
, ST_ASSIGNMENT
);
417 match (NULL
, gfc_match_pointer_assignment
, ST_POINTER_ASSIGNMENT
);
419 if (in_specification_block
)
421 m
= match_word (NULL
, gfc_match_st_function
, &old_locus
);
423 return ST_STATEMENT_FUNCTION
;
426 if (!(in_specification_block
&& m
== MATCH_ERROR
))
428 match (NULL
, gfc_match_ptr_fcn_assign
, ST_ASSIGNMENT
);
431 match (NULL
, gfc_match_data_decl
, ST_DATA_DECL
);
432 match (NULL
, gfc_match_enumerator_def
, ST_ENUMERATOR
);
434 /* Try to match a subroutine statement, which has the same optional
435 prefixes that functions can have. */
437 if (gfc_match_subroutine () == MATCH_YES
)
438 return ST_SUBROUTINE
;
440 gfc_current_locus
= old_locus
;
442 if (gfc_match_submod_proc () == MATCH_YES
)
444 if (gfc_new_block
->attr
.subroutine
)
445 return ST_SUBROUTINE
;
446 else if (gfc_new_block
->attr
.function
)
450 gfc_current_locus
= old_locus
;
452 /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
453 statements, which might begin with a block label. The match functions for
454 these statements are unusual in that their keyword is not seen before
455 the matcher is called. */
457 if (gfc_match_if (&st
) == MATCH_YES
)
460 gfc_current_locus
= old_locus
;
462 if (gfc_match_where (&st
) == MATCH_YES
)
465 gfc_current_locus
= old_locus
;
467 if (gfc_match_forall (&st
) == MATCH_YES
)
470 gfc_current_locus
= old_locus
;
472 /* Try to match TYPE as an alias for PRINT. */
473 if (gfc_match_type (&st
) == MATCH_YES
)
476 gfc_current_locus
= old_locus
;
478 match (NULL
, gfc_match_do
, ST_DO
);
479 match (NULL
, gfc_match_block
, ST_BLOCK
);
480 match (NULL
, gfc_match_associate
, ST_ASSOCIATE
);
481 match (NULL
, gfc_match_critical
, ST_CRITICAL
);
482 match (NULL
, gfc_match_select
, ST_SELECT_CASE
);
483 match (NULL
, gfc_match_select_type
, ST_SELECT_TYPE
);
484 match (NULL
, gfc_match_select_rank
, ST_SELECT_RANK
);
486 /* General statement matching: Instead of testing every possible
487 statement, we eliminate most possibilities by peeking at the
493 match ("abstract% interface", gfc_match_abstract_interface
,
495 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
);
496 match ("allocatable", gfc_match_allocatable
, ST_ATTR_DECL
);
497 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
);
498 match ("asynchronous", gfc_match_asynchronous
, ST_ATTR_DECL
);
499 match ("automatic", gfc_match_automatic
, ST_ATTR_DECL
);
503 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
);
504 match ("block data", gfc_match_block_data
, ST_BLOCK_DATA
);
505 match (NULL
, gfc_match_bind_c_stmt
, ST_ATTR_DECL
);
509 match ("call", gfc_match_call
, ST_CALL
);
510 match ("change% team", gfc_match_change_team
, ST_CHANGE_TEAM
);
511 match ("close", gfc_match_close
, ST_CLOSE
);
512 match ("continue", gfc_match_continue
, ST_CONTINUE
);
513 match ("contiguous", gfc_match_contiguous
, ST_ATTR_DECL
);
514 match ("cycle", gfc_match_cycle
, ST_CYCLE
);
515 match ("case", gfc_match_case
, ST_CASE
);
516 match ("common", gfc_match_common
, ST_COMMON
);
517 match ("contains", gfc_match_eos
, ST_CONTAINS
);
518 match ("class", gfc_match_class_is
, ST_CLASS_IS
);
519 match ("codimension", gfc_match_codimension
, ST_ATTR_DECL
);
523 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
);
524 match ("data", gfc_match_data
, ST_DATA
);
525 match ("dimension", gfc_match_dimension
, ST_ATTR_DECL
);
529 match ("end file", gfc_match_endfile
, ST_END_FILE
);
530 match ("end team", gfc_match_end_team
, ST_END_TEAM
);
531 match ("exit", gfc_match_exit
, ST_EXIT
);
532 match ("else", gfc_match_else
, ST_ELSE
);
533 match ("else where", gfc_match_elsewhere
, ST_ELSEWHERE
);
534 match ("else if", gfc_match_elseif
, ST_ELSEIF
);
535 match ("error% stop", gfc_match_error_stop
, ST_ERROR_STOP
);
536 match ("enum , bind ( c )", gfc_match_enum
, ST_ENUM
);
538 if (gfc_match_end (&st
) == MATCH_YES
)
541 match ("entry% ", gfc_match_entry
, ST_ENTRY
);
542 match ("equivalence", gfc_match_equivalence
, ST_EQUIVALENCE
);
543 match ("external", gfc_match_external
, ST_ATTR_DECL
);
544 match ("event% post", gfc_match_event_post
, ST_EVENT_POST
);
545 match ("event% wait", gfc_match_event_wait
, ST_EVENT_WAIT
);
549 match ("fail% image", gfc_match_fail_image
, ST_FAIL_IMAGE
);
550 match ("final", gfc_match_final_decl
, ST_FINAL
);
551 match ("flush", gfc_match_flush
, ST_FLUSH
);
552 match ("form% team", gfc_match_form_team
, ST_FORM_TEAM
);
553 match ("format", gfc_match_format
, ST_FORMAT
);
557 match ("generic", gfc_match_generic
, ST_GENERIC
);
558 match ("go to", gfc_match_goto
, ST_GOTO
);
562 match ("inquire", gfc_match_inquire
, ST_INQUIRE
);
563 match ("implicit", gfc_match_implicit
, ST_IMPLICIT
);
564 match ("implicit% none", gfc_match_implicit_none
, ST_IMPLICIT_NONE
);
565 match ("import", gfc_match_import
, ST_IMPORT
);
566 match ("interface", gfc_match_interface
, ST_INTERFACE
);
567 match ("intent", gfc_match_intent
, ST_ATTR_DECL
);
568 match ("intrinsic", gfc_match_intrinsic
, ST_ATTR_DECL
);
572 match ("lock", gfc_match_lock
, ST_LOCK
);
576 match ("map", gfc_match_map
, ST_MAP
);
577 match ("module% procedure", gfc_match_modproc
, ST_MODULE_PROC
);
578 match ("module", gfc_match_module
, ST_MODULE
);
582 match ("nullify", gfc_match_nullify
, ST_NULLIFY
);
583 match ("namelist", gfc_match_namelist
, ST_NAMELIST
);
587 match ("open", gfc_match_open
, ST_OPEN
);
588 match ("optional", gfc_match_optional
, ST_ATTR_DECL
);
592 match ("print", gfc_match_print
, ST_WRITE
);
593 match ("pause", gfc_match_pause
, ST_PAUSE
);
594 match ("pointer", gfc_match_pointer
, ST_ATTR_DECL
);
595 if (gfc_match_private (&st
) == MATCH_YES
)
597 match ("procedure", gfc_match_procedure
, ST_PROCEDURE
);
598 match ("program", gfc_match_program
, ST_PROGRAM
);
599 if (gfc_match_public (&st
) == MATCH_YES
)
601 match ("protected", gfc_match_protected
, ST_ATTR_DECL
);
605 match ("rank", gfc_match_rank_is
, ST_RANK
);
606 match ("read", gfc_match_read
, ST_READ
);
607 match ("return", gfc_match_return
, ST_RETURN
);
608 match ("rewind", gfc_match_rewind
, ST_REWIND
);
612 match ("structure", gfc_match_structure_decl
, ST_STRUCTURE_DECL
);
613 match ("sequence", gfc_match_eos
, ST_SEQUENCE
);
614 match ("stop", gfc_match_stop
, ST_STOP
);
615 match ("save", gfc_match_save
, ST_ATTR_DECL
);
616 match ("static", gfc_match_static
, ST_ATTR_DECL
);
617 match ("submodule", gfc_match_submodule
, ST_SUBMODULE
);
618 match ("sync% all", gfc_match_sync_all
, ST_SYNC_ALL
);
619 match ("sync% images", gfc_match_sync_images
, ST_SYNC_IMAGES
);
620 match ("sync% memory", gfc_match_sync_memory
, ST_SYNC_MEMORY
);
621 match ("sync% team", gfc_match_sync_team
, ST_SYNC_TEAM
);
625 match ("target", gfc_match_target
, ST_ATTR_DECL
);
626 match ("type", gfc_match_derived_decl
, ST_DERIVED_DECL
);
627 match ("type% is", gfc_match_type_is
, ST_TYPE_IS
);
631 match ("union", gfc_match_union
, ST_UNION
);
632 match ("unlock", gfc_match_unlock
, ST_UNLOCK
);
636 match ("value", gfc_match_value
, ST_ATTR_DECL
);
637 match ("volatile", gfc_match_volatile
, ST_ATTR_DECL
);
641 match ("wait", gfc_match_wait
, ST_WAIT
);
642 match ("write", gfc_match_write
, ST_WRITE
);
646 /* All else has failed, so give up. See if any of the matchers has
647 stored an error message of some sort. Suppress the "Unclassifiable
648 statement" if a previous error message was emitted, e.g., by
650 if (!gfc_error_check ())
653 gfc_get_errors (NULL
, &ecnt
);
655 gfc_error_now ("Unclassifiable statement at %C");
660 gfc_error_recovery ();
665 /* Like match and if spec_only, goto do_spec_only without actually
667 /* If the directive matched but the clauses failed, do not start
668 matching the next directive in the same switch statement. */
669 #define matcha(keyword, subr, st) \
672 if (spec_only && gfc_match (keyword) == MATCH_YES) \
674 else if ((m2 = match_word (keyword, subr, &old_locus)) \
677 else if (m2 == MATCH_ERROR) \
678 goto error_handling; \
680 undo_new_statement (); \
684 decode_oacc_directive (void)
688 bool spec_only
= false;
690 gfc_enforce_clean_symbol_state ();
692 gfc_clear_error (); /* Clear any pending errors. */
693 gfc_clear_warning (); /* Clear any pending warnings. */
695 gfc_matching_function
= false;
697 if (gfc_current_state () == COMP_FUNCTION
698 && gfc_current_block ()->result
->ts
.kind
== -1)
701 old_locus
= gfc_current_locus
;
703 /* General OpenACC directive matching: Instead of testing every possible
704 statement, we eliminate most possibilities by peeking at the
707 c
= gfc_peek_ascii_char ();
712 matcha ("routine", gfc_match_oacc_routine
, ST_OACC_ROUTINE
);
716 gfc_unset_implicit_pure (NULL
);
719 gfc_error_now ("OpenACC directives other than ROUTINE may not appear in PURE "
727 matcha ("atomic", gfc_match_oacc_atomic
, ST_OACC_ATOMIC
);
730 matcha ("cache", gfc_match_oacc_cache
, ST_OACC_CACHE
);
733 matcha ("data", gfc_match_oacc_data
, ST_OACC_DATA
);
734 match ("declare", gfc_match_oacc_declare
, ST_OACC_DECLARE
);
737 matcha ("end atomic", gfc_match_omp_eos_error
, ST_OACC_END_ATOMIC
);
738 matcha ("end data", gfc_match_omp_eos_error
, ST_OACC_END_DATA
);
739 matcha ("end host_data", gfc_match_omp_eos_error
, ST_OACC_END_HOST_DATA
);
740 matcha ("end kernels loop", gfc_match_omp_eos_error
, ST_OACC_END_KERNELS_LOOP
);
741 matcha ("end kernels", gfc_match_omp_eos_error
, ST_OACC_END_KERNELS
);
742 matcha ("end loop", gfc_match_omp_eos_error
, ST_OACC_END_LOOP
);
743 matcha ("end parallel loop", gfc_match_omp_eos_error
,
744 ST_OACC_END_PARALLEL_LOOP
);
745 matcha ("end parallel", gfc_match_omp_eos_error
, ST_OACC_END_PARALLEL
);
746 matcha ("end serial loop", gfc_match_omp_eos_error
,
747 ST_OACC_END_SERIAL_LOOP
);
748 matcha ("end serial", gfc_match_omp_eos_error
, ST_OACC_END_SERIAL
);
749 matcha ("enter data", gfc_match_oacc_enter_data
, ST_OACC_ENTER_DATA
);
750 matcha ("exit data", gfc_match_oacc_exit_data
, ST_OACC_EXIT_DATA
);
753 matcha ("host_data", gfc_match_oacc_host_data
, ST_OACC_HOST_DATA
);
756 matcha ("parallel loop", gfc_match_oacc_parallel_loop
,
757 ST_OACC_PARALLEL_LOOP
);
758 matcha ("parallel", gfc_match_oacc_parallel
, ST_OACC_PARALLEL
);
761 matcha ("kernels loop", gfc_match_oacc_kernels_loop
,
762 ST_OACC_KERNELS_LOOP
);
763 matcha ("kernels", gfc_match_oacc_kernels
, ST_OACC_KERNELS
);
766 matcha ("loop", gfc_match_oacc_loop
, ST_OACC_LOOP
);
769 matcha ("serial loop", gfc_match_oacc_serial_loop
, ST_OACC_SERIAL_LOOP
);
770 matcha ("serial", gfc_match_oacc_serial
, ST_OACC_SERIAL
);
773 matcha ("update", gfc_match_oacc_update
, ST_OACC_UPDATE
);
776 matcha ("wait", gfc_match_oacc_wait
, ST_OACC_WAIT
);
780 /* Directive not found or stored an error message.
781 Check and give up. */
784 if (gfc_error_check () == 0)
785 gfc_error_now ("Unclassifiable OpenACC directive at %C");
789 gfc_error_recovery ();
796 gfc_buffer_error (false);
797 gfc_current_locus
= old_locus
;
798 return ST_GET_FCN_CHARACTERISTICS
;
801 /* Checks for the ST_OMP_ALLOCATE. First, check whether all list items
802 are allocatables/pointers - and if so, assume it is associated with a Fortran
803 ALLOCATE stmt. If not, do some initial parsing-related checks and append
804 namelist to namespace.
805 The check follows OpenMP 5.1 by requiring an executable stmt or OpenMP
806 construct before a directive associated with an allocate statement
807 (-> ST_OMP_ALLOCATE_EXEC); instead of showing an error, conversion of
808 ST_OMP_ALLOCATE -> ST_OMP_ALLOCATE_EXEC would be an alternative. */
811 check_omp_allocate_stmt (locus
*loc
)
815 if (new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->sym
== NULL
)
817 gfc_error ("%qs directive at %L must either have a variable argument or, "
818 "if associated with an ALLOCATE stmt, must be preceded by an "
819 "executable statement or OpenMP construct",
820 gfc_ascii_statement (ST_OMP_ALLOCATE
), loc
);
823 bool has_allocatable
= false;
824 bool has_non_allocatable
= false;
825 for (n
= new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]; n
; n
= n
->next
)
829 gfc_error ("Structure-component expression at %L in %qs directive not"
830 " permitted in declarative directive; as directive "
831 "associated with an ALLOCATE stmt it must be preceded by "
832 "an executable statement or OpenMP construct",
833 &n
->expr
->where
, gfc_ascii_statement (ST_OMP_ALLOCATE
));
836 /* Procedure pointers are not allocatable; hence, we do not regard them as
837 pointers here - and reject them later in gfc_resolve_omp_allocate. */
839 if (n
->sym
->ts
.type
== BT_CLASS
&& n
->sym
->attr
.class_ok
)
840 alloc_ptr
= (CLASS_DATA (n
->sym
)->attr
.allocatable
841 || CLASS_DATA (n
->sym
)->attr
.class_pointer
);
843 alloc_ptr
= n
->sym
->attr
.allocatable
|| n
->sym
->attr
.pointer
;
845 || (n
->sym
->ns
&& n
->sym
->ns
->proc_name
846 && (n
->sym
->ns
->proc_name
->attr
.allocatable
847 || n
->sym
->ns
->proc_name
->attr
.pointer
)))
848 has_allocatable
= true;
850 has_non_allocatable
= true;
852 /* All allocatables - assume it is allocated with an ALLOCATE stmt. */
853 if (has_allocatable
&& !has_non_allocatable
)
855 gfc_error ("%qs directive at %L associated with an ALLOCATE stmt must be "
856 "preceded by an executable statement or OpenMP construct; "
857 "note the variables in the list all have the allocatable or "
858 "pointer attribute", gfc_ascii_statement (ST_OMP_ALLOCATE
),
862 if (!gfc_current_ns
->omp_allocate
)
863 gfc_current_ns
->omp_allocate
864 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
];
867 for (n
= gfc_current_ns
->omp_allocate
; n
->next
; n
= n
->next
)
869 n
->next
= new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
];
871 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
] = NULL
;
872 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
877 /* Like match, but set a flag simd_matched if keyword matched
878 and if spec_only, goto do_spec_only without actually matching. */
879 #define matchs(keyword, subr, st) \
882 if (spec_only && gfc_match (keyword) == MATCH_YES) \
884 if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \
885 &simd_matched)) == MATCH_YES) \
890 else if (m2 == MATCH_ERROR) \
891 goto error_handling; \
893 undo_new_statement (); \
896 /* Like match, but don't match anything if not -fopenmp
897 and if spec_only, goto do_spec_only without actually matching. */
898 /* If the directive matched but the clauses failed, do not start
899 matching the next directive in the same switch statement. */
900 #define matcho(keyword, subr, st) \
905 else if (spec_only && gfc_match (keyword) == MATCH_YES) \
907 else if ((m2 = match_word (keyword, subr, &old_locus)) \
913 else if (m2 == MATCH_ERROR) \
914 goto error_handling; \
916 undo_new_statement (); \
919 /* Like match, but set a flag simd_matched if keyword matched. */
920 #define matchds(keyword, subr, st) \
923 if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \
924 &simd_matched)) == MATCH_YES) \
929 else if (m2 == MATCH_ERROR) \
930 goto error_handling; \
932 undo_new_statement (); \
935 /* Like match, but don't match anything if not -fopenmp. */
936 #define matchdo(keyword, subr, st) \
941 else if ((m2 = match_word (keyword, subr, &old_locus)) \
947 else if (m2 == MATCH_ERROR) \
948 goto error_handling; \
950 undo_new_statement (); \
954 decode_omp_directive (void)
958 bool simd_matched
= false;
959 bool spec_only
= false;
960 gfc_statement ret
= ST_NONE
;
963 gfc_enforce_clean_symbol_state ();
965 gfc_clear_error (); /* Clear any pending errors. */
966 gfc_clear_warning (); /* Clear any pending warnings. */
968 gfc_matching_function
= false;
970 if (gfc_current_state () == COMP_FUNCTION
971 && gfc_current_block ()->result
->ts
.kind
== -1)
974 old_locus
= gfc_current_locus
;
976 /* General OpenMP directive matching: Instead of testing every possible
977 statement, we eliminate most possibilities by peeking at the
980 c
= gfc_peek_ascii_char ();
982 /* match is for directives that should be recognized only if
983 -fopenmp, matchs for directives that should be recognized
984 if either -fopenmp or -fopenmp-simd.
985 Handle only the directives allowed in PURE procedures
986 first (those also shall not turn off implicit pure). */
990 /* For -fopenmp-simd, ignore 'assumes'; note no clause starts with 's'. */
991 if (!flag_openmp
&& gfc_match ("assumes") == MATCH_YES
)
993 matcho ("assumes", gfc_match_omp_assumes
, ST_OMP_ASSUMES
);
994 matchs ("assume", gfc_match_omp_assume
, ST_OMP_ASSUME
);
997 matchds ("declare reduction", gfc_match_omp_declare_reduction
,
998 ST_OMP_DECLARE_REDUCTION
);
999 matchds ("declare simd", gfc_match_omp_declare_simd
,
1000 ST_OMP_DECLARE_SIMD
);
1001 matchdo ("declare target", gfc_match_omp_declare_target
,
1002 ST_OMP_DECLARE_TARGET
);
1003 matchdo ("declare variant", gfc_match_omp_declare_variant
,
1004 ST_OMP_DECLARE_VARIANT
);
1007 matchs ("end assume", gfc_match_omp_eos_error
, ST_OMP_END_ASSUME
);
1008 matchs ("end simd", gfc_match_omp_eos_error
, ST_OMP_END_SIMD
);
1009 matcho ("error", gfc_match_omp_error
, ST_OMP_ERROR
);
1012 matchs ("scan", gfc_match_omp_scan
, ST_OMP_SCAN
);
1013 matchs ("simd", gfc_match_omp_simd
, ST_OMP_SIMD
);
1016 matcho ("nothing", gfc_match_omp_nothing
, ST_NONE
);
1021 if (flag_openmp
&& gfc_pure (NULL
))
1023 gfc_error_now ("OpenMP directive at %C is not pure and thus may not "
1024 "appear in a PURE procedure");
1025 gfc_error_recovery ();
1029 /* match is for directives that should be recognized only if
1030 -fopenmp, matchs for directives that should be recognized
1031 if either -fopenmp or -fopenmp-simd. */
1036 matcho ("allocate", gfc_match_omp_allocate
, ST_OMP_ALLOCATE_EXEC
);
1038 matcho ("allocate", gfc_match_omp_allocate
, ST_OMP_ALLOCATE
);
1039 matcho ("allocators", gfc_match_omp_allocators
, ST_OMP_ALLOCATORS
);
1040 matcho ("atomic", gfc_match_omp_atomic
, ST_OMP_ATOMIC
);
1043 matcho ("barrier", gfc_match_omp_barrier
, ST_OMP_BARRIER
);
1046 matcho ("cancellation% point", gfc_match_omp_cancellation_point
,
1047 ST_OMP_CANCELLATION_POINT
);
1048 matcho ("cancel", gfc_match_omp_cancel
, ST_OMP_CANCEL
);
1049 matcho ("critical", gfc_match_omp_critical
, ST_OMP_CRITICAL
);
1052 matcho ("depobj", gfc_match_omp_depobj
, ST_OMP_DEPOBJ
);
1053 matchs ("distribute parallel do simd",
1054 gfc_match_omp_distribute_parallel_do_simd
,
1055 ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
);
1056 matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do
,
1057 ST_OMP_DISTRIBUTE_PARALLEL_DO
);
1058 matchs ("distribute simd", gfc_match_omp_distribute_simd
,
1059 ST_OMP_DISTRIBUTE_SIMD
);
1060 matcho ("distribute", gfc_match_omp_distribute
, ST_OMP_DISTRIBUTE
);
1061 matchs ("do simd", gfc_match_omp_do_simd
, ST_OMP_DO_SIMD
);
1062 matcho ("do", gfc_match_omp_do
, ST_OMP_DO
);
1065 matcho ("end allocators", gfc_match_omp_eos_error
, ST_OMP_END_ALLOCATORS
);
1066 matcho ("end atomic", gfc_match_omp_eos_error
, ST_OMP_END_ATOMIC
);
1067 matcho ("end critical", gfc_match_omp_end_critical
, ST_OMP_END_CRITICAL
);
1068 matchs ("end distribute parallel do simd", gfc_match_omp_eos_error
,
1069 ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
);
1070 matcho ("end distribute parallel do", gfc_match_omp_eos_error
,
1071 ST_OMP_END_DISTRIBUTE_PARALLEL_DO
);
1072 matchs ("end distribute simd", gfc_match_omp_eos_error
,
1073 ST_OMP_END_DISTRIBUTE_SIMD
);
1074 matcho ("end distribute", gfc_match_omp_eos_error
, ST_OMP_END_DISTRIBUTE
);
1075 matchs ("end do simd", gfc_match_omp_end_nowait
, ST_OMP_END_DO_SIMD
);
1076 matcho ("end do", gfc_match_omp_end_nowait
, ST_OMP_END_DO
);
1077 matchs ("end loop", gfc_match_omp_eos_error
, ST_OMP_END_LOOP
);
1078 matcho ("end masked taskloop simd", gfc_match_omp_eos_error
,
1079 ST_OMP_END_MASKED_TASKLOOP_SIMD
);
1080 matcho ("end masked taskloop", gfc_match_omp_eos_error
,
1081 ST_OMP_END_MASKED_TASKLOOP
);
1082 matcho ("end masked", gfc_match_omp_eos_error
, ST_OMP_END_MASKED
);
1083 matcho ("end master taskloop simd", gfc_match_omp_eos_error
,
1084 ST_OMP_END_MASTER_TASKLOOP_SIMD
);
1085 matcho ("end master taskloop", gfc_match_omp_eos_error
,
1086 ST_OMP_END_MASTER_TASKLOOP
);
1087 matcho ("end master", gfc_match_omp_eos_error
, ST_OMP_END_MASTER
);
1088 matchs ("end ordered", gfc_match_omp_eos_error
, ST_OMP_END_ORDERED
);
1089 matchs ("end parallel do simd", gfc_match_omp_eos_error
,
1090 ST_OMP_END_PARALLEL_DO_SIMD
);
1091 matcho ("end parallel do", gfc_match_omp_eos_error
,
1092 ST_OMP_END_PARALLEL_DO
);
1093 matcho ("end parallel loop", gfc_match_omp_eos_error
,
1094 ST_OMP_END_PARALLEL_LOOP
);
1095 matcho ("end parallel masked taskloop simd", gfc_match_omp_eos_error
,
1096 ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD
);
1097 matcho ("end parallel masked taskloop", gfc_match_omp_eos_error
,
1098 ST_OMP_END_PARALLEL_MASKED_TASKLOOP
);
1099 matcho ("end parallel masked", gfc_match_omp_eos_error
,
1100 ST_OMP_END_PARALLEL_MASKED
);
1101 matcho ("end parallel master taskloop simd", gfc_match_omp_eos_error
,
1102 ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD
);
1103 matcho ("end parallel master taskloop", gfc_match_omp_eos_error
,
1104 ST_OMP_END_PARALLEL_MASTER_TASKLOOP
);
1105 matcho ("end parallel master", gfc_match_omp_eos_error
,
1106 ST_OMP_END_PARALLEL_MASTER
);
1107 matcho ("end parallel sections", gfc_match_omp_eos_error
,
1108 ST_OMP_END_PARALLEL_SECTIONS
);
1109 matcho ("end parallel workshare", gfc_match_omp_eos_error
,
1110 ST_OMP_END_PARALLEL_WORKSHARE
);
1111 matcho ("end parallel", gfc_match_omp_eos_error
, ST_OMP_END_PARALLEL
);
1112 matcho ("end scope", gfc_match_omp_end_nowait
, ST_OMP_END_SCOPE
);
1113 matcho ("end sections", gfc_match_omp_end_nowait
, ST_OMP_END_SECTIONS
);
1114 matcho ("end single", gfc_match_omp_end_single
, ST_OMP_END_SINGLE
);
1115 matcho ("end target data", gfc_match_omp_eos_error
, ST_OMP_END_TARGET_DATA
);
1116 matchs ("end target parallel do simd", gfc_match_omp_end_nowait
,
1117 ST_OMP_END_TARGET_PARALLEL_DO_SIMD
);
1118 matcho ("end target parallel do", gfc_match_omp_end_nowait
,
1119 ST_OMP_END_TARGET_PARALLEL_DO
);
1120 matcho ("end target parallel loop", gfc_match_omp_end_nowait
,
1121 ST_OMP_END_TARGET_PARALLEL_LOOP
);
1122 matcho ("end target parallel", gfc_match_omp_end_nowait
,
1123 ST_OMP_END_TARGET_PARALLEL
);
1124 matchs ("end target simd", gfc_match_omp_end_nowait
, ST_OMP_END_TARGET_SIMD
);
1125 matchs ("end target teams distribute parallel do simd",
1126 gfc_match_omp_end_nowait
,
1127 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
1128 matcho ("end target teams distribute parallel do", gfc_match_omp_end_nowait
,
1129 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
1130 matchs ("end target teams distribute simd", gfc_match_omp_end_nowait
,
1131 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
);
1132 matcho ("end target teams distribute", gfc_match_omp_end_nowait
,
1133 ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
);
1134 matcho ("end target teams loop", gfc_match_omp_end_nowait
,
1135 ST_OMP_END_TARGET_TEAMS_LOOP
);
1136 matcho ("end target teams", gfc_match_omp_end_nowait
,
1137 ST_OMP_END_TARGET_TEAMS
);
1138 matcho ("end target", gfc_match_omp_end_nowait
, ST_OMP_END_TARGET
);
1139 matcho ("end taskgroup", gfc_match_omp_eos_error
, ST_OMP_END_TASKGROUP
);
1140 matchs ("end taskloop simd", gfc_match_omp_eos_error
,
1141 ST_OMP_END_TASKLOOP_SIMD
);
1142 matcho ("end taskloop", gfc_match_omp_eos_error
, ST_OMP_END_TASKLOOP
);
1143 matcho ("end task", gfc_match_omp_eos_error
, ST_OMP_END_TASK
);
1144 matchs ("end teams distribute parallel do simd", gfc_match_omp_eos_error
,
1145 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
1146 matcho ("end teams distribute parallel do", gfc_match_omp_eos_error
,
1147 ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
);
1148 matchs ("end teams distribute simd", gfc_match_omp_eos_error
,
1149 ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
);
1150 matcho ("end teams distribute", gfc_match_omp_eos_error
,
1151 ST_OMP_END_TEAMS_DISTRIBUTE
);
1152 matcho ("end teams loop", gfc_match_omp_eos_error
, ST_OMP_END_TEAMS_LOOP
);
1153 matcho ("end teams", gfc_match_omp_eos_error
, ST_OMP_END_TEAMS
);
1154 matcho ("end workshare", gfc_match_omp_end_nowait
,
1155 ST_OMP_END_WORKSHARE
);
1158 matcho ("flush", gfc_match_omp_flush
, ST_OMP_FLUSH
);
1161 matcho ("masked taskloop simd", gfc_match_omp_masked_taskloop_simd
,
1162 ST_OMP_MASKED_TASKLOOP_SIMD
);
1163 matcho ("masked taskloop", gfc_match_omp_masked_taskloop
,
1164 ST_OMP_MASKED_TASKLOOP
);
1165 matcho ("masked", gfc_match_omp_masked
, ST_OMP_MASKED
);
1166 matcho ("master taskloop simd", gfc_match_omp_master_taskloop_simd
,
1167 ST_OMP_MASTER_TASKLOOP_SIMD
);
1168 matcho ("master taskloop", gfc_match_omp_master_taskloop
,
1169 ST_OMP_MASTER_TASKLOOP
);
1170 matcho ("master", gfc_match_omp_master
, ST_OMP_MASTER
);
1173 matcho ("nothing", gfc_match_omp_nothing
, ST_NONE
);
1176 matchs ("loop", gfc_match_omp_loop
, ST_OMP_LOOP
);
1179 if (gfc_match ("ordered depend (") == MATCH_YES
1180 || gfc_match ("ordered doacross (") == MATCH_YES
)
1182 gfc_current_locus
= old_locus
;
1185 matcho ("ordered", gfc_match_omp_ordered_depend
,
1186 ST_OMP_ORDERED_DEPEND
);
1189 matchs ("ordered", gfc_match_omp_ordered
, ST_OMP_ORDERED
);
1192 matchs ("parallel do simd", gfc_match_omp_parallel_do_simd
,
1193 ST_OMP_PARALLEL_DO_SIMD
);
1194 matcho ("parallel do", gfc_match_omp_parallel_do
, ST_OMP_PARALLEL_DO
);
1195 matcho ("parallel loop", gfc_match_omp_parallel_loop
,
1196 ST_OMP_PARALLEL_LOOP
);
1197 matcho ("parallel masked taskloop simd",
1198 gfc_match_omp_parallel_masked_taskloop_simd
,
1199 ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
);
1200 matcho ("parallel masked taskloop",
1201 gfc_match_omp_parallel_masked_taskloop
,
1202 ST_OMP_PARALLEL_MASKED_TASKLOOP
);
1203 matcho ("parallel masked", gfc_match_omp_parallel_masked
,
1204 ST_OMP_PARALLEL_MASKED
);
1205 matcho ("parallel master taskloop simd",
1206 gfc_match_omp_parallel_master_taskloop_simd
,
1207 ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
);
1208 matcho ("parallel master taskloop",
1209 gfc_match_omp_parallel_master_taskloop
,
1210 ST_OMP_PARALLEL_MASTER_TASKLOOP
);
1211 matcho ("parallel master", gfc_match_omp_parallel_master
,
1212 ST_OMP_PARALLEL_MASTER
);
1213 matcho ("parallel sections", gfc_match_omp_parallel_sections
,
1214 ST_OMP_PARALLEL_SECTIONS
);
1215 matcho ("parallel workshare", gfc_match_omp_parallel_workshare
,
1216 ST_OMP_PARALLEL_WORKSHARE
);
1217 matcho ("parallel", gfc_match_omp_parallel
, ST_OMP_PARALLEL
);
1220 matcho ("requires", gfc_match_omp_requires
, ST_OMP_REQUIRES
);
1223 matcho ("scope", gfc_match_omp_scope
, ST_OMP_SCOPE
);
1224 matcho ("sections", gfc_match_omp_sections
, ST_OMP_SECTIONS
);
1225 matcho ("section", gfc_match_omp_eos_error
, ST_OMP_SECTION
);
1226 matcho ("single", gfc_match_omp_single
, ST_OMP_SINGLE
);
1229 matcho ("target data", gfc_match_omp_target_data
, ST_OMP_TARGET_DATA
);
1230 matcho ("target enter data", gfc_match_omp_target_enter_data
,
1231 ST_OMP_TARGET_ENTER_DATA
);
1232 matcho ("target exit data", gfc_match_omp_target_exit_data
,
1233 ST_OMP_TARGET_EXIT_DATA
);
1234 matchs ("target parallel do simd", gfc_match_omp_target_parallel_do_simd
,
1235 ST_OMP_TARGET_PARALLEL_DO_SIMD
);
1236 matcho ("target parallel do", gfc_match_omp_target_parallel_do
,
1237 ST_OMP_TARGET_PARALLEL_DO
);
1238 matcho ("target parallel loop", gfc_match_omp_target_parallel_loop
,
1239 ST_OMP_TARGET_PARALLEL_LOOP
);
1240 matcho ("target parallel", gfc_match_omp_target_parallel
,
1241 ST_OMP_TARGET_PARALLEL
);
1242 matchs ("target simd", gfc_match_omp_target_simd
, ST_OMP_TARGET_SIMD
);
1243 matchs ("target teams distribute parallel do simd",
1244 gfc_match_omp_target_teams_distribute_parallel_do_simd
,
1245 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
1246 matcho ("target teams distribute parallel do",
1247 gfc_match_omp_target_teams_distribute_parallel_do
,
1248 ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
);
1249 matchs ("target teams distribute simd",
1250 gfc_match_omp_target_teams_distribute_simd
,
1251 ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
);
1252 matcho ("target teams distribute", gfc_match_omp_target_teams_distribute
,
1253 ST_OMP_TARGET_TEAMS_DISTRIBUTE
);
1254 matcho ("target teams loop", gfc_match_omp_target_teams_loop
,
1255 ST_OMP_TARGET_TEAMS_LOOP
);
1256 matcho ("target teams", gfc_match_omp_target_teams
, ST_OMP_TARGET_TEAMS
);
1257 matcho ("target update", gfc_match_omp_target_update
,
1258 ST_OMP_TARGET_UPDATE
);
1259 matcho ("target", gfc_match_omp_target
, ST_OMP_TARGET
);
1260 matcho ("taskgroup", gfc_match_omp_taskgroup
, ST_OMP_TASKGROUP
);
1261 matchs ("taskloop simd", gfc_match_omp_taskloop_simd
,
1262 ST_OMP_TASKLOOP_SIMD
);
1263 matcho ("taskloop", gfc_match_omp_taskloop
, ST_OMP_TASKLOOP
);
1264 matcho ("taskwait", gfc_match_omp_taskwait
, ST_OMP_TASKWAIT
);
1265 matcho ("taskyield", gfc_match_omp_taskyield
, ST_OMP_TASKYIELD
);
1266 matcho ("task", gfc_match_omp_task
, ST_OMP_TASK
);
1267 matchs ("teams distribute parallel do simd",
1268 gfc_match_omp_teams_distribute_parallel_do_simd
,
1269 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
);
1270 matcho ("teams distribute parallel do",
1271 gfc_match_omp_teams_distribute_parallel_do
,
1272 ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
);
1273 matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd
,
1274 ST_OMP_TEAMS_DISTRIBUTE_SIMD
);
1275 matcho ("teams distribute", gfc_match_omp_teams_distribute
,
1276 ST_OMP_TEAMS_DISTRIBUTE
);
1277 matcho ("teams loop", gfc_match_omp_teams_loop
, ST_OMP_TEAMS_LOOP
);
1278 matcho ("teams", gfc_match_omp_teams
, ST_OMP_TEAMS
);
1279 matchdo ("threadprivate", gfc_match_omp_threadprivate
,
1280 ST_OMP_THREADPRIVATE
);
1283 matcho ("workshare", gfc_match_omp_workshare
, ST_OMP_WORKSHARE
);
1287 /* All else has failed, so give up. See if any of the matchers has
1288 stored an error message of some sort. Don't error out if
1289 not -fopenmp and simd_matched is false, i.e. if a directive other
1290 than one marked with match has been seen. */
1293 if (flag_openmp
|| simd_matched
)
1295 if (!gfc_error_check ())
1296 gfc_error_now ("Unclassifiable OpenMP directive at %C");
1299 reject_statement ();
1301 gfc_error_recovery ();
1306 if (ret
== ST_OMP_ERROR
&& new_st
.ext
.omp_clauses
->at
== OMP_AT_EXECUTION
)
1308 gfc_unset_implicit_pure (NULL
);
1310 if (gfc_pure (NULL
))
1312 gfc_error_now ("OpenMP ERROR directive at %L with %<at(execution)%> "
1313 "clause in a PURE procedure", &old_locus
);
1314 reject_statement ();
1315 gfc_error_recovery ();
1321 gfc_unset_implicit_pure (NULL
);
1323 if (!flag_openmp
&& gfc_pure (NULL
))
1325 gfc_error_now ("OpenMP directive at %C is not pure and thus may not "
1326 "appear in a PURE procedure");
1327 reject_statement ();
1328 gfc_error_recovery ();
1332 if (ret
== ST_OMP_ALLOCATE
&& !check_omp_allocate_stmt (&old_locus
))
1333 goto error_handling
;
1337 /* Set omp_target_seen; exclude ST_OMP_DECLARE_TARGET.
1338 FIXME: Get clarification, cf. OpenMP Spec Issue #3240. */
1340 case ST_OMP_TARGET_DATA
:
1341 case ST_OMP_TARGET_ENTER_DATA
:
1342 case ST_OMP_TARGET_EXIT_DATA
:
1343 case ST_OMP_TARGET_TEAMS
:
1344 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
1345 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
1346 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1347 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1348 case ST_OMP_TARGET_TEAMS_LOOP
:
1349 case ST_OMP_TARGET_PARALLEL
:
1350 case ST_OMP_TARGET_PARALLEL_DO
:
1351 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
1352 case ST_OMP_TARGET_PARALLEL_LOOP
:
1353 case ST_OMP_TARGET_SIMD
:
1354 case ST_OMP_TARGET_UPDATE
:
1356 gfc_namespace
*prog_unit
= gfc_current_ns
;
1357 while (prog_unit
->parent
)
1359 if (gfc_state_stack
->previous
1360 && gfc_state_stack
->previous
->state
== COMP_INTERFACE
)
1362 prog_unit
= prog_unit
->parent
;
1364 prog_unit
->omp_target_seen
= true;
1368 case ST_OMP_TEAMS_DISTRIBUTE
:
1369 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
1370 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1371 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1372 case ST_OMP_TEAMS_LOOP
:
1373 for (gfc_state_data
*stk
= gfc_state_stack
->previous
; stk
;
1374 stk
= stk
->previous
)
1375 if (stk
&& stk
->tail
)
1376 switch (stk
->tail
->op
)
1378 case EXEC_OMP_TARGET
:
1379 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
1380 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
1381 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1382 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1383 case EXEC_OMP_TARGET_TEAMS_LOOP
:
1384 case EXEC_OMP_TARGET_PARALLEL
:
1385 case EXEC_OMP_TARGET_PARALLEL_DO
:
1386 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
1387 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
1388 case EXEC_OMP_TARGET_SIMD
:
1389 stk
->tail
->ext
.omp_clauses
->contains_teams_construct
= 1;
1396 if (new_st
.ext
.omp_clauses
->at
!= OMP_AT_EXECUTION
)
1404 reject_statement ();
1406 gfc_buffer_error (false);
1407 gfc_current_locus
= old_locus
;
1408 return ST_GET_FCN_CHARACTERISTICS
;
1411 static gfc_statement
1412 decode_gcc_attribute (void)
1416 gfc_enforce_clean_symbol_state ();
1418 gfc_clear_error (); /* Clear any pending errors. */
1419 gfc_clear_warning (); /* Clear any pending warnings. */
1420 old_locus
= gfc_current_locus
;
1422 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
1423 match ("unroll", gfc_match_gcc_unroll
, ST_NONE
);
1424 match ("builtin", gfc_match_gcc_builtin
, ST_NONE
);
1425 match ("ivdep", gfc_match_gcc_ivdep
, ST_NONE
);
1426 match ("vector", gfc_match_gcc_vector
, ST_NONE
);
1427 match ("novector", gfc_match_gcc_novector
, ST_NONE
);
1429 /* All else has failed, so give up. See if any of the matchers has
1430 stored an error message of some sort. */
1432 if (!gfc_error_check ())
1435 gfc_error_now ("Unclassifiable GCC directive at %C");
1437 gfc_warning_now (0, "Unclassifiable GCC directive at %C, ignored");
1440 reject_statement ();
1442 gfc_error_recovery ();
1449 /* Assert next length characters to be equal to token in free form. */
1452 verify_token_free (const char* token
, int length
, bool last_was_use_stmt
)
1457 c
= gfc_next_ascii_char ();
1458 for (i
= 0; i
< length
; i
++, c
= gfc_next_ascii_char ())
1459 gcc_assert (c
== token
[i
]);
1461 gcc_assert (gfc_is_whitespace(c
));
1462 gfc_gobble_whitespace ();
1463 if (last_was_use_stmt
)
1467 /* Get the next statement in free form source. */
1469 static gfc_statement
1476 at_bol
= gfc_at_bol ();
1477 gfc_gobble_whitespace ();
1479 c
= gfc_peek_ascii_char ();
1485 /* Found a statement label? */
1486 m
= gfc_match_st_label (&gfc_statement_label
);
1488 d
= gfc_peek_ascii_char ();
1489 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
1491 gfc_match_small_literal_int (&i
, &cnt
);
1494 gfc_error_now ("Too many digits in statement label at %C");
1497 gfc_error_now ("Zero is not a valid statement label at %C");
1500 c
= gfc_next_ascii_char ();
1503 if (!gfc_is_whitespace (c
))
1504 gfc_error_now ("Non-numeric character in statement label at %C");
1510 label_locus
= gfc_current_locus
;
1512 gfc_gobble_whitespace ();
1514 if (at_bol
&& gfc_peek_ascii_char () == ';')
1516 gfc_error_now ("Semicolon at %C needs to be preceded by "
1518 gfc_next_ascii_char (); /* Eat up the semicolon. */
1522 if (gfc_match_eos () == MATCH_YES
)
1523 gfc_error_now ("Statement label without statement at %L",
1529 /* Comments have already been skipped by the time we get here,
1530 except for GCC attributes and OpenMP/OpenACC directives. */
1532 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
1533 c
= gfc_peek_ascii_char ();
1539 c
= gfc_next_ascii_char ();
1540 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
1541 gcc_assert (c
== "gcc$"[i
]);
1543 gfc_gobble_whitespace ();
1544 return decode_gcc_attribute ();
1549 /* Since both OpenMP and OpenACC directives starts with
1550 !$ character sequence, we must check all flags combinations */
1551 if ((flag_openmp
|| flag_openmp_simd
)
1554 verify_token_free ("$omp", 4, last_was_use_stmt
);
1555 return decode_omp_directive ();
1557 else if ((flag_openmp
|| flag_openmp_simd
)
1560 gfc_next_ascii_char (); /* Eat up dollar character */
1561 c
= gfc_peek_ascii_char ();
1565 verify_token_free ("omp", 3, last_was_use_stmt
);
1566 return decode_omp_directive ();
1570 verify_token_free ("acc", 3, last_was_use_stmt
);
1571 return decode_oacc_directive ();
1574 else if (flag_openacc
)
1576 verify_token_free ("$acc", 4, last_was_use_stmt
);
1577 return decode_oacc_directive ();
1583 if (at_bol
&& c
== ';')
1585 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1586 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1588 gfc_next_ascii_char (); /* Eat up the semicolon. */
1592 return decode_statement ();
1595 /* Assert next length characters to be equal to token in fixed form. */
1598 verify_token_fixed (const char *token
, int length
, bool last_was_use_stmt
)
1601 char c
= gfc_next_char_literal (NONSTRING
);
1603 for (i
= 0; i
< length
; i
++, c
= gfc_next_char_literal (NONSTRING
))
1604 gcc_assert ((char) gfc_wide_tolower (c
) == token
[i
]);
1606 if (c
!= ' ' && c
!= '0')
1608 gfc_buffer_error (false);
1609 gfc_error ("Bad continuation line at %C");
1612 if (last_was_use_stmt
)
1618 /* Get the next statement in fixed-form source. */
1620 static gfc_statement
1623 int label
, digit_flag
, i
;
1628 return decode_statement ();
1630 /* Skip past the current label field, parsing a statement label if
1631 one is there. This is a weird number parser, since the number is
1632 contained within five columns and can have any kind of embedded
1633 spaces. We also check for characters that make the rest of the
1639 for (i
= 0; i
< 5; i
++)
1641 c
= gfc_next_char_literal (NONSTRING
);
1658 label
= label
* 10 + ((unsigned char) c
- '0');
1659 label_locus
= gfc_current_locus
;
1663 /* Comments have already been skipped by the time we get
1664 here, except for GCC attributes and OpenMP directives. */
1667 c
= gfc_next_char_literal (NONSTRING
);
1669 if (TOLOWER (c
) == 'g')
1671 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
1672 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
1674 return decode_gcc_attribute ();
1678 if ((flag_openmp
|| flag_openmp_simd
)
1681 if (!verify_token_fixed ("omp", 3, last_was_use_stmt
))
1683 return decode_omp_directive ();
1685 else if ((flag_openmp
|| flag_openmp_simd
)
1688 c
= gfc_next_char_literal(NONSTRING
);
1689 if (c
== 'o' || c
== 'O')
1691 if (!verify_token_fixed ("mp", 2, last_was_use_stmt
))
1693 return decode_omp_directive ();
1695 else if (c
== 'a' || c
== 'A')
1697 if (!verify_token_fixed ("cc", 2, last_was_use_stmt
))
1699 return decode_oacc_directive ();
1702 else if (flag_openacc
)
1704 if (!verify_token_fixed ("acc", 3, last_was_use_stmt
))
1706 return decode_oacc_directive ();
1711 /* Comments have already been skipped by the time we get
1712 here so don't bother checking for them. */
1715 gfc_buffer_error (false);
1716 gfc_error ("Non-numeric character in statement label at %C");
1724 gfc_warning_now (0, "Zero is not a valid statement label at %C");
1727 /* We've found a valid statement label. */
1728 gfc_statement_label
= gfc_get_st_label (label
);
1732 /* Since this line starts a statement, it cannot be a continuation
1733 of a previous statement. If we see something here besides a
1734 space or zero, it must be a bad continuation line. */
1736 c
= gfc_next_char_literal (NONSTRING
);
1740 if (c
!= ' ' && c
!= '0')
1742 gfc_buffer_error (false);
1743 gfc_error ("Bad continuation line at %C");
1747 /* Now that we've taken care of the statement label columns, we have
1748 to make sure that the first nonblank character is not a '!'. If
1749 it is, the rest of the line is a comment. */
1753 loc
= gfc_current_locus
;
1754 c
= gfc_next_char_literal (NONSTRING
);
1756 while (gfc_is_whitespace (c
));
1760 gfc_current_locus
= loc
;
1765 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1766 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1767 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1772 if (gfc_match_eos () == MATCH_YES
)
1775 /* At this point, we've got a nonblank statement to parse. */
1776 return decode_statement ();
1780 gfc_error_now ("Statement label without statement at %L", &label_locus
);
1782 gfc_current_locus
.lb
->truncated
= 0;
1783 gfc_advance_line ();
1788 /* Return the next non-ST_NONE statement to the caller. We also worry
1789 about including files and the ends of include files at this stage. */
1791 static gfc_statement
1792 next_statement (void)
1797 gfc_enforce_clean_symbol_state ();
1799 gfc_new_block
= NULL
;
1801 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1802 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
1805 gfc_statement_label
= NULL
;
1806 gfc_buffer_error (true);
1809 gfc_advance_line ();
1811 gfc_skip_comments ();
1819 if (gfc_define_undef_line ())
1822 old_locus
= gfc_current_locus
;
1824 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1830 gfc_buffer_error (false);
1832 if (st
== ST_GET_FCN_CHARACTERISTICS
)
1834 if (gfc_statement_label
!= NULL
)
1836 gfc_free_st_label (gfc_statement_label
);
1837 gfc_statement_label
= NULL
;
1839 gfc_current_locus
= old_locus
;
1843 check_statement_label (st
);
1849 /****************************** Parser ***********************************/
1851 /* The parser subroutines are of type 'try' that fail if the file ends
1854 /* Macros that expand to case-labels for various classes of
1855 statements. Start with executable statements that directly do
1858 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1859 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1860 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1861 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1862 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1863 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1864 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1865 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1866 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1867 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: case ST_OMP_DEPOBJ: \
1868 case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
1869 case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: case ST_OMP_ERROR: \
1870 case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \
1871 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1872 case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
1873 case ST_END_TEAM: case ST_SYNC_TEAM: \
1874 case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
1875 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1876 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1878 /* Statements that mark other executable statements. */
1880 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1881 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1882 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1883 case ST_SELECT_RANK: case ST_OMP_PARALLEL: case ST_OMP_PARALLEL_MASKED: \
1884 case ST_OMP_PARALLEL_MASKED_TASKLOOP: \
1885 case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: case ST_OMP_PARALLEL_MASTER: \
1886 case ST_OMP_PARALLEL_MASTER_TASKLOOP: \
1887 case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: \
1888 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1889 case ST_OMP_CRITICAL: case ST_OMP_MASKED: case ST_OMP_MASKED_TASKLOOP: \
1890 case ST_OMP_MASKED_TASKLOOP_SIMD: \
1891 case ST_OMP_MASTER: case ST_OMP_MASTER_TASKLOOP: \
1892 case ST_OMP_MASTER_TASKLOOP_SIMD: case ST_OMP_SCOPE: case ST_OMP_SINGLE: \
1893 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1894 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1895 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1896 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1897 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1898 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1899 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1900 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1901 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1902 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1903 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1904 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1905 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1906 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1907 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \
1908 case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \
1909 case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
1910 case ST_OMP_LOOP: case ST_OMP_PARALLEL_LOOP: case ST_OMP_TEAMS_LOOP: \
1911 case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_TEAMS_LOOP: \
1912 case ST_OMP_ALLOCATE_EXEC: case ST_OMP_ALLOCATORS: case ST_OMP_ASSUME: \
1914 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1915 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
1916 case ST_OACC_KERNELS_LOOP: case ST_OACC_SERIAL_LOOP: case ST_OACC_SERIAL: \
1919 /* Declaration statements */
1921 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1922 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1923 case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE
1925 /* OpenMP and OpenACC declaration statements, which may appear anywhere in
1926 the specification part. */
1928 #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
1929 case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \
1930 case ST_OMP_DECLARE_VARIANT: case ST_OMP_ALLOCATE: case ST_OMP_ASSUMES: \
1931 case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
1933 /* Block end statements. Errors associated with interchanging these
1934 are detected in gfc_match_end(). */
1936 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1937 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1938 case ST_END_BLOCK: case ST_END_ASSOCIATE
1941 /* Push a new state onto the stack. */
1944 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1946 p
->state
= new_state
;
1947 p
->previous
= gfc_state_stack
;
1949 p
->head
= p
->tail
= NULL
;
1950 p
->do_variable
= NULL
;
1951 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1952 p
->ext
.oacc_declare_clauses
= NULL
;
1954 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1955 construct statement was accepted right before pushing the state. Thus,
1956 the construct's gfc_code is available as tail of the parent state. */
1957 gcc_assert (gfc_state_stack
);
1958 p
->construct
= gfc_state_stack
->tail
;
1960 gfc_state_stack
= p
;
1964 /* Pop the current state. */
1968 gfc_state_stack
= gfc_state_stack
->previous
;
1972 /* Try to find the given state in the state stack. */
1975 gfc_find_state (gfc_compile_state state
)
1979 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1980 if (p
->state
== state
)
1983 return (p
== NULL
) ? false : true;
1987 /* Starts a new level in the statement list. */
1990 new_level (gfc_code
*q
)
1994 p
= q
->block
= gfc_get_code (EXEC_NOP
);
1996 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
2002 /* Add the current new_st code structure and adds it to the current
2003 program unit. As a side-effect, it zeroes the new_st. */
2006 add_statement (void)
2010 p
= XCNEW (gfc_code
);
2013 p
->loc
= gfc_current_locus
;
2015 if (gfc_state_stack
->head
== NULL
)
2016 gfc_state_stack
->head
= p
;
2018 gfc_state_stack
->tail
->next
= p
;
2020 while (p
->next
!= NULL
)
2023 gfc_state_stack
->tail
= p
;
2025 gfc_clear_new_st ();
2031 /* Frees everything associated with the current statement. */
2034 undo_new_statement (void)
2036 gfc_free_statements (new_st
.block
);
2037 gfc_free_statements (new_st
.next
);
2038 gfc_free_statement (&new_st
);
2039 gfc_clear_new_st ();
2043 /* If the current statement has a statement label, make sure that it
2044 is allowed to, or should have one. */
2047 check_statement_label (gfc_statement st
)
2051 if (gfc_statement_label
== NULL
)
2053 if (st
== ST_FORMAT
)
2054 gfc_error ("FORMAT statement at %L does not have a statement label",
2061 case ST_END_PROGRAM
:
2062 case ST_END_FUNCTION
:
2063 case ST_END_SUBROUTINE
:
2067 case ST_END_CRITICAL
:
2069 case ST_END_ASSOCIATE
:
2072 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
2073 type
= ST_LABEL_DO_TARGET
;
2075 type
= ST_LABEL_TARGET
;
2079 type
= ST_LABEL_FORMAT
;
2082 /* Statement labels are not restricted from appearing on a
2083 particular line. However, there are plenty of situations
2084 where the resulting label can't be referenced. */
2087 type
= ST_LABEL_BAD_TARGET
;
2091 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
2093 new_st
.here
= gfc_statement_label
;
2097 /* Figures out what the enclosing program unit is. This will be a
2098 function, subroutine, program, block data or module. */
2101 gfc_enclosing_unit (gfc_compile_state
* result
)
2105 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
2106 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
2107 || p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
2108 || p
->state
== COMP_BLOCK_DATA
|| p
->state
== COMP_PROGRAM
)
2117 *result
= COMP_PROGRAM
;
2122 /* Translate a statement enum to a string. If strip_sentinel is true,
2123 the !$OMP/!$ACC sentinel is excluded. */
2126 gfc_ascii_statement (gfc_statement st
, bool strip_sentinel
)
2132 case ST_ARITHMETIC_IF
:
2133 p
= _("arithmetic IF");
2142 p
= _("attribute declaration");
2178 p
= _("data declaration");
2192 case ST_STRUCTURE_DECL
:
2195 case ST_DERIVED_DECL
:
2196 p
= _("derived type declaration");
2219 case ST_CHANGE_TEAM
:
2231 case ST_END_ASSOCIATE
:
2232 p
= "END ASSOCIATE";
2237 case ST_END_BLOCK_DATA
:
2238 p
= "END BLOCK DATA";
2240 case ST_END_CRITICAL
:
2252 case ST_END_FUNCTION
:
2258 case ST_END_INTERFACE
:
2259 p
= "END INTERFACE";
2264 case ST_END_SUBMODULE
:
2265 p
= "END SUBMODULE";
2267 case ST_END_PROGRAM
:
2273 case ST_END_SUBROUTINE
:
2274 p
= "END SUBROUTINE";
2279 case ST_END_STRUCTURE
:
2280 p
= "END STRUCTURE";
2294 case ST_EQUIVALENCE
:
2306 case ST_FORALL_BLOCK
: /* Fall through */
2328 case ST_IMPLICIT_NONE
:
2329 p
= "IMPLICIT NONE";
2331 case ST_IMPLIED_ENDDO
:
2332 p
= _("implied END DO");
2364 case ST_MODULE_PROC
:
2365 p
= "MODULE PROCEDURE";
2397 case ST_SYNC_IMAGES
:
2400 case ST_SYNC_MEMORY
:
2415 case ST_WHERE_BLOCK
: /* Fall through */
2426 p
= _("assignment");
2428 case ST_POINTER_ASSIGNMENT
:
2429 p
= _("pointer assignment");
2431 case ST_SELECT_CASE
:
2434 case ST_SELECT_TYPE
:
2437 case ST_SELECT_RANK
:
2455 case ST_STATEMENT_FUNCTION
:
2456 p
= "STATEMENT FUNCTION";
2458 case ST_LABEL_ASSIGNMENT
:
2459 p
= "LABEL ASSIGNMENT";
2462 p
= "ENUM DEFINITION";
2465 p
= "ENUMERATOR DEFINITION";
2470 case ST_OACC_PARALLEL_LOOP
:
2471 p
= "!$ACC PARALLEL LOOP";
2473 case ST_OACC_END_PARALLEL_LOOP
:
2474 p
= "!$ACC END PARALLEL LOOP";
2476 case ST_OACC_PARALLEL
:
2477 p
= "!$ACC PARALLEL";
2479 case ST_OACC_END_PARALLEL
:
2480 p
= "!$ACC END PARALLEL";
2482 case ST_OACC_KERNELS
:
2483 p
= "!$ACC KERNELS";
2485 case ST_OACC_END_KERNELS
:
2486 p
= "!$ACC END KERNELS";
2488 case ST_OACC_KERNELS_LOOP
:
2489 p
= "!$ACC KERNELS LOOP";
2491 case ST_OACC_END_KERNELS_LOOP
:
2492 p
= "!$ACC END KERNELS LOOP";
2494 case ST_OACC_SERIAL_LOOP
:
2495 p
= "!$ACC SERIAL LOOP";
2497 case ST_OACC_END_SERIAL_LOOP
:
2498 p
= "!$ACC END SERIAL LOOP";
2500 case ST_OACC_SERIAL
:
2503 case ST_OACC_END_SERIAL
:
2504 p
= "!$ACC END SERIAL";
2509 case ST_OACC_END_DATA
:
2510 p
= "!$ACC END DATA";
2512 case ST_OACC_HOST_DATA
:
2513 p
= "!$ACC HOST_DATA";
2515 case ST_OACC_END_HOST_DATA
:
2516 p
= "!$ACC END HOST_DATA";
2521 case ST_OACC_END_LOOP
:
2522 p
= "!$ACC END LOOP";
2524 case ST_OACC_DECLARE
:
2525 p
= "!$ACC DECLARE";
2527 case ST_OACC_UPDATE
:
2536 case ST_OACC_ENTER_DATA
:
2537 p
= "!$ACC ENTER DATA";
2539 case ST_OACC_EXIT_DATA
:
2540 p
= "!$ACC EXIT DATA";
2542 case ST_OACC_ROUTINE
:
2543 p
= "!$ACC ROUTINE";
2545 case ST_OACC_ATOMIC
:
2548 case ST_OACC_END_ATOMIC
:
2549 p
= "!$ACC END ATOMIC";
2551 case ST_OMP_ALLOCATE
:
2552 case ST_OMP_ALLOCATE_EXEC
:
2553 p
= "!$OMP ALLOCATE";
2555 case ST_OMP_ALLOCATORS
:
2556 p
= "!$OMP ALLOCATORS";
2561 case ST_OMP_ASSUMES
:
2562 p
= "!$OMP ASSUMES";
2567 case ST_OMP_BARRIER
:
2568 p
= "!$OMP BARRIER";
2573 case ST_OMP_CANCELLATION_POINT
:
2574 p
= "!$OMP CANCELLATION POINT";
2576 case ST_OMP_CRITICAL
:
2577 p
= "!$OMP CRITICAL";
2579 case ST_OMP_DECLARE_REDUCTION
:
2580 p
= "!$OMP DECLARE REDUCTION";
2582 case ST_OMP_DECLARE_SIMD
:
2583 p
= "!$OMP DECLARE SIMD";
2585 case ST_OMP_DECLARE_TARGET
:
2586 p
= "!$OMP DECLARE TARGET";
2588 case ST_OMP_DECLARE_VARIANT
:
2589 p
= "!$OMP DECLARE VARIANT";
2594 case ST_OMP_DISTRIBUTE
:
2595 p
= "!$OMP DISTRIBUTE";
2597 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
2598 p
= "!$OMP DISTRIBUTE PARALLEL DO";
2600 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2601 p
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
2603 case ST_OMP_DISTRIBUTE_SIMD
:
2604 p
= "!$OMP DISTRIBUTE SIMD";
2609 case ST_OMP_DO_SIMD
:
2610 p
= "!$OMP DO SIMD";
2612 case ST_OMP_END_ALLOCATORS
:
2613 p
= "!$OMP END ALLOCATORS";
2615 case ST_OMP_END_ASSUME
:
2616 p
= "!$OMP END ASSUME";
2618 case ST_OMP_END_ATOMIC
:
2619 p
= "!$OMP END ATOMIC";
2621 case ST_OMP_END_CRITICAL
:
2622 p
= "!$OMP END CRITICAL";
2624 case ST_OMP_END_DISTRIBUTE
:
2625 p
= "!$OMP END DISTRIBUTE";
2627 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO
:
2628 p
= "!$OMP END DISTRIBUTE PARALLEL DO";
2630 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
:
2631 p
= "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
2633 case ST_OMP_END_DISTRIBUTE_SIMD
:
2634 p
= "!$OMP END DISTRIBUTE SIMD";
2639 case ST_OMP_END_DO_SIMD
:
2640 p
= "!$OMP END DO SIMD";
2642 case ST_OMP_END_SCOPE
:
2643 p
= "!$OMP END SCOPE";
2645 case ST_OMP_END_SIMD
:
2646 p
= "!$OMP END SIMD";
2648 case ST_OMP_END_LOOP
:
2649 p
= "!$OMP END LOOP";
2651 case ST_OMP_END_MASKED
:
2652 p
= "!$OMP END MASKED";
2654 case ST_OMP_END_MASKED_TASKLOOP
:
2655 p
= "!$OMP END MASKED TASKLOOP";
2657 case ST_OMP_END_MASKED_TASKLOOP_SIMD
:
2658 p
= "!$OMP END MASKED TASKLOOP SIMD";
2660 case ST_OMP_END_MASTER
:
2661 p
= "!$OMP END MASTER";
2663 case ST_OMP_END_MASTER_TASKLOOP
:
2664 p
= "!$OMP END MASTER TASKLOOP";
2666 case ST_OMP_END_MASTER_TASKLOOP_SIMD
:
2667 p
= "!$OMP END MASTER TASKLOOP SIMD";
2669 case ST_OMP_END_ORDERED
:
2670 p
= "!$OMP END ORDERED";
2672 case ST_OMP_END_PARALLEL
:
2673 p
= "!$OMP END PARALLEL";
2675 case ST_OMP_END_PARALLEL_DO
:
2676 p
= "!$OMP END PARALLEL DO";
2678 case ST_OMP_END_PARALLEL_DO_SIMD
:
2679 p
= "!$OMP END PARALLEL DO SIMD";
2681 case ST_OMP_END_PARALLEL_LOOP
:
2682 p
= "!$OMP END PARALLEL LOOP";
2684 case ST_OMP_END_PARALLEL_MASKED
:
2685 p
= "!$OMP END PARALLEL MASKED";
2687 case ST_OMP_END_PARALLEL_MASKED_TASKLOOP
:
2688 p
= "!$OMP END PARALLEL MASKED TASKLOOP";
2690 case ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD
:
2691 p
= "!$OMP END PARALLEL MASKED TASKLOOP SIMD";
2693 case ST_OMP_END_PARALLEL_MASTER
:
2694 p
= "!$OMP END PARALLEL MASTER";
2696 case ST_OMP_END_PARALLEL_MASTER_TASKLOOP
:
2697 p
= "!$OMP END PARALLEL MASTER TASKLOOP";
2699 case ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD
:
2700 p
= "!$OMP END PARALLEL MASTER TASKLOOP SIMD";
2702 case ST_OMP_END_PARALLEL_SECTIONS
:
2703 p
= "!$OMP END PARALLEL SECTIONS";
2705 case ST_OMP_END_PARALLEL_WORKSHARE
:
2706 p
= "!$OMP END PARALLEL WORKSHARE";
2708 case ST_OMP_END_SECTIONS
:
2709 p
= "!$OMP END SECTIONS";
2711 case ST_OMP_END_SINGLE
:
2712 p
= "!$OMP END SINGLE";
2714 case ST_OMP_END_TASK
:
2715 p
= "!$OMP END TASK";
2717 case ST_OMP_END_TARGET
:
2718 p
= "!$OMP END TARGET";
2720 case ST_OMP_END_TARGET_DATA
:
2721 p
= "!$OMP END TARGET DATA";
2723 case ST_OMP_END_TARGET_PARALLEL
:
2724 p
= "!$OMP END TARGET PARALLEL";
2726 case ST_OMP_END_TARGET_PARALLEL_DO
:
2727 p
= "!$OMP END TARGET PARALLEL DO";
2729 case ST_OMP_END_TARGET_PARALLEL_DO_SIMD
:
2730 p
= "!$OMP END TARGET PARALLEL DO SIMD";
2732 case ST_OMP_END_TARGET_PARALLEL_LOOP
:
2733 p
= "!$OMP END TARGET PARALLEL LOOP";
2735 case ST_OMP_END_TARGET_SIMD
:
2736 p
= "!$OMP END TARGET SIMD";
2738 case ST_OMP_END_TARGET_TEAMS
:
2739 p
= "!$OMP END TARGET TEAMS";
2741 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
:
2742 p
= "!$OMP END TARGET TEAMS DISTRIBUTE";
2744 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2745 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2747 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2748 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2750 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2751 p
= "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2753 case ST_OMP_END_TARGET_TEAMS_LOOP
:
2754 p
= "!$OMP END TARGET TEAMS LOOP";
2756 case ST_OMP_END_TASKGROUP
:
2757 p
= "!$OMP END TASKGROUP";
2759 case ST_OMP_END_TASKLOOP
:
2760 p
= "!$OMP END TASKLOOP";
2762 case ST_OMP_END_TASKLOOP_SIMD
:
2763 p
= "!$OMP END TASKLOOP SIMD";
2765 case ST_OMP_END_TEAMS
:
2766 p
= "!$OMP END TEAMS";
2768 case ST_OMP_END_TEAMS_DISTRIBUTE
:
2769 p
= "!$OMP END TEAMS DISTRIBUTE";
2771 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2772 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2774 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2775 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2777 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
:
2778 p
= "!$OMP END TEAMS DISTRIBUTE SIMD";
2780 case ST_OMP_END_TEAMS_LOOP
:
2781 p
= "!$OMP END TEAMS LOOP";
2783 case ST_OMP_END_WORKSHARE
:
2784 p
= "!$OMP END WORKSHARE";
2798 case ST_OMP_MASKED_TASKLOOP
:
2799 p
= "!$OMP MASKED TASKLOOP";
2801 case ST_OMP_MASKED_TASKLOOP_SIMD
:
2802 p
= "!$OMP MASKED TASKLOOP SIMD";
2807 case ST_OMP_MASTER_TASKLOOP
:
2808 p
= "!$OMP MASTER TASKLOOP";
2810 case ST_OMP_MASTER_TASKLOOP_SIMD
:
2811 p
= "!$OMP MASTER TASKLOOP SIMD";
2813 case ST_OMP_ORDERED
:
2814 case ST_OMP_ORDERED_DEPEND
:
2815 p
= "!$OMP ORDERED";
2817 case ST_OMP_NOTHING
:
2818 /* Note: gfc_match_omp_nothing returns ST_NONE. */
2819 p
= "!$OMP NOTHING";
2821 case ST_OMP_PARALLEL
:
2822 p
= "!$OMP PARALLEL";
2824 case ST_OMP_PARALLEL_DO
:
2825 p
= "!$OMP PARALLEL DO";
2827 case ST_OMP_PARALLEL_LOOP
:
2828 p
= "!$OMP PARALLEL LOOP";
2830 case ST_OMP_PARALLEL_DO_SIMD
:
2831 p
= "!$OMP PARALLEL DO SIMD";
2833 case ST_OMP_PARALLEL_MASKED
:
2834 p
= "!$OMP PARALLEL MASKED";
2836 case ST_OMP_PARALLEL_MASKED_TASKLOOP
:
2837 p
= "!$OMP PARALLEL MASKED TASKLOOP";
2839 case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
2840 p
= "!$OMP PARALLEL MASKED TASKLOOP SIMD";
2842 case ST_OMP_PARALLEL_MASTER
:
2843 p
= "!$OMP PARALLEL MASTER";
2845 case ST_OMP_PARALLEL_MASTER_TASKLOOP
:
2846 p
= "!$OMP PARALLEL MASTER TASKLOOP";
2848 case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
2849 p
= "!$OMP PARALLEL MASTER TASKLOOP SIMD";
2851 case ST_OMP_PARALLEL_SECTIONS
:
2852 p
= "!$OMP PARALLEL SECTIONS";
2854 case ST_OMP_PARALLEL_WORKSHARE
:
2855 p
= "!$OMP PARALLEL WORKSHARE";
2857 case ST_OMP_REQUIRES
:
2858 p
= "!$OMP REQUIRES";
2866 case ST_OMP_SECTIONS
:
2867 p
= "!$OMP SECTIONS";
2869 case ST_OMP_SECTION
:
2870 p
= "!$OMP SECTION";
2881 case ST_OMP_TARGET_DATA
:
2882 p
= "!$OMP TARGET DATA";
2884 case ST_OMP_TARGET_ENTER_DATA
:
2885 p
= "!$OMP TARGET ENTER DATA";
2887 case ST_OMP_TARGET_EXIT_DATA
:
2888 p
= "!$OMP TARGET EXIT DATA";
2890 case ST_OMP_TARGET_PARALLEL
:
2891 p
= "!$OMP TARGET PARALLEL";
2893 case ST_OMP_TARGET_PARALLEL_DO
:
2894 p
= "!$OMP TARGET PARALLEL DO";
2896 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
2897 p
= "!$OMP TARGET PARALLEL DO SIMD";
2899 case ST_OMP_TARGET_PARALLEL_LOOP
:
2900 p
= "!$OMP TARGET PARALLEL LOOP";
2902 case ST_OMP_TARGET_SIMD
:
2903 p
= "!$OMP TARGET SIMD";
2905 case ST_OMP_TARGET_TEAMS
:
2906 p
= "!$OMP TARGET TEAMS";
2908 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
2909 p
= "!$OMP TARGET TEAMS DISTRIBUTE";
2911 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2912 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2914 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2915 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2917 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2918 p
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2920 case ST_OMP_TARGET_TEAMS_LOOP
:
2921 p
= "!$OMP TARGET TEAMS LOOP";
2923 case ST_OMP_TARGET_UPDATE
:
2924 p
= "!$OMP TARGET UPDATE";
2929 case ST_OMP_TASKGROUP
:
2930 p
= "!$OMP TASKGROUP";
2932 case ST_OMP_TASKLOOP
:
2933 p
= "!$OMP TASKLOOP";
2935 case ST_OMP_TASKLOOP_SIMD
:
2936 p
= "!$OMP TASKLOOP SIMD";
2938 case ST_OMP_TASKWAIT
:
2939 p
= "!$OMP TASKWAIT";
2941 case ST_OMP_TASKYIELD
:
2942 p
= "!$OMP TASKYIELD";
2947 case ST_OMP_TEAMS_DISTRIBUTE
:
2948 p
= "!$OMP TEAMS DISTRIBUTE";
2950 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2951 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2953 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2954 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2956 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
2957 p
= "!$OMP TEAMS DISTRIBUTE SIMD";
2959 case ST_OMP_TEAMS_LOOP
:
2960 p
= "!$OMP TEAMS LOOP";
2962 case ST_OMP_THREADPRIVATE
:
2963 p
= "!$OMP THREADPRIVATE";
2965 case ST_OMP_WORKSHARE
:
2966 p
= "!$OMP WORKSHARE";
2969 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2972 if (strip_sentinel
&& p
[0] == '!')
2973 return p
+ strlen ("!$OMP ");
2978 /* Create a symbol for the main program and assign it to ns->proc_name. */
2981 main_program_symbol (gfc_namespace
*ns
, const char *name
)
2983 gfc_symbol
*main_program
;
2984 symbol_attribute attr
;
2986 gfc_get_symbol (name
, ns
, &main_program
);
2987 gfc_clear_attr (&attr
);
2988 attr
.flavor
= FL_PROGRAM
;
2989 attr
.proc
= PROC_UNKNOWN
;
2990 attr
.subroutine
= 1;
2991 attr
.access
= ACCESS_PUBLIC
;
2992 attr
.is_main_program
= 1;
2993 main_program
->attr
= attr
;
2994 main_program
->declared_at
= gfc_current_locus
;
2995 ns
->proc_name
= main_program
;
2996 gfc_commit_symbols ();
3000 /* Do whatever is necessary to accept the last statement. */
3003 accept_statement (gfc_statement st
)
3007 case ST_IMPLICIT_NONE
:
3015 gfc_current_ns
->proc_name
= gfc_new_block
;
3018 /* If the statement is the end of a block, lay down a special code
3019 that allows a branch to the end of the block from within the
3020 construct. IF and SELECT are treated differently from DO
3021 (where EXEC_NOP is added inside the loop) for two
3023 1. END DO has a meaning in the sense that after a GOTO to
3024 it, the loop counter must be increased.
3025 2. IF blocks and SELECT blocks can consist of multiple
3026 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
3027 Putting the label before the END IF would make the jump
3028 from, say, the ELSE IF block to the END IF illegal. */
3032 case ST_END_CRITICAL
:
3033 if (gfc_statement_label
!= NULL
)
3035 new_st
.op
= EXEC_END_NESTED_BLOCK
;
3040 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
3041 one parallel block. Thus, we add the special code to the nested block
3042 itself, instead of the parent one. */
3044 case ST_END_ASSOCIATE
:
3045 if (gfc_statement_label
!= NULL
)
3047 new_st
.op
= EXEC_END_BLOCK
;
3052 /* The end-of-program unit statements do not get the special
3053 marker and require a statement of some sort if they are a
3056 case ST_END_PROGRAM
:
3057 case ST_END_FUNCTION
:
3058 case ST_END_SUBROUTINE
:
3059 if (gfc_statement_label
!= NULL
)
3061 new_st
.op
= EXEC_RETURN
;
3066 new_st
.op
= EXEC_END_PROCEDURE
;
3082 gfc_commit_symbols ();
3083 gfc_warning_check ();
3084 gfc_clear_new_st ();
3088 /* Undo anything tentative that has been built for the current statement,
3089 except if a gfc_charlen structure has been added to current namespace's
3090 list of gfc_charlen structure. */
3093 reject_statement (void)
3095 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
3096 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
3097 gfc_drop_interface_elements_before (current_interface_ptr
,
3098 previous_interface_head
);
3100 gfc_reject_data (gfc_current_ns
);
3102 gfc_new_block
= NULL
;
3103 gfc_undo_symbols ();
3104 gfc_clear_warning ();
3105 undo_new_statement ();
3109 /* Generic complaint about an out of order statement. We also do
3110 whatever is necessary to clean up. */
3113 unexpected_statement (gfc_statement st
)
3115 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
3117 reject_statement ();
3121 /* Given the next statement seen by the matcher, make sure that it is
3122 in proper order with the last. This subroutine is initialized by
3123 calling it with an argument of ST_NONE. If there is a problem, we
3124 issue an error and return false. Otherwise we return true.
3126 Individual parsers need to verify that the statements seen are
3127 valid before calling here, i.e., ENTRY statements are not allowed in
3128 INTERFACE blocks. The following diagram is taken from the standard:
3130 +---------------------------------------+
3131 | program subroutine function module |
3132 +---------------------------------------+
3134 +---------------------------------------+
3136 +---------------------------------------+
3138 | +-----------+------------------+
3139 | | parameter | implicit |
3140 | +-----------+------------------+
3141 | format | | derived type |
3142 | entry | parameter | interface |
3143 | | data | specification |
3144 | | | statement func |
3145 | +-----------+------------------+
3146 | | data | executable |
3147 +--------+-----------+------------------+
3149 +---------------------------------------+
3150 | internal module/subprogram |
3151 +---------------------------------------+
3153 +---------------------------------------+
3162 ORDER_IMPLICIT_NONE
,
3170 enum state_order state
;
3171 gfc_statement last_statement
;
3177 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
3183 p
->state
= ORDER_START
;
3184 in_exec_part
= false;
3188 if (p
->state
> ORDER_USE
)
3190 p
->state
= ORDER_USE
;
3194 if (p
->state
> ORDER_IMPORT
)
3196 p
->state
= ORDER_IMPORT
;
3199 case ST_IMPLICIT_NONE
:
3200 if (p
->state
> ORDER_IMPLICIT
)
3203 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
3204 statement disqualifies a USE but not an IMPLICIT NONE.
3205 Duplicate IMPLICIT NONEs are caught when the implicit types
3208 p
->state
= ORDER_IMPLICIT_NONE
;
3212 if (p
->state
> ORDER_IMPLICIT
)
3214 p
->state
= ORDER_IMPLICIT
;
3219 if (p
->state
< ORDER_IMPLICIT_NONE
)
3220 p
->state
= ORDER_IMPLICIT_NONE
;
3224 if (p
->state
>= ORDER_EXEC
)
3226 if (p
->state
< ORDER_IMPLICIT
)
3227 p
->state
= ORDER_IMPLICIT
;
3231 if (p
->state
< ORDER_SPEC
)
3232 p
->state
= ORDER_SPEC
;
3237 case ST_STRUCTURE_DECL
:
3238 case ST_DERIVED_DECL
:
3240 if (p
->state
>= ORDER_EXEC
)
3242 if (p
->state
< ORDER_SPEC
)
3243 p
->state
= ORDER_SPEC
;
3247 /* The OpenMP/OpenACC directives have to be somewhere in the specification
3248 part, but there are no further requirements on their ordering.
3249 Thus don't adjust p->state, just ignore them. */
3250 if (p
->state
>= ORDER_EXEC
)
3256 if (p
->state
< ORDER_EXEC
)
3257 p
->state
= ORDER_EXEC
;
3258 in_exec_part
= true;
3265 /* All is well, record the statement in case we need it next time. */
3266 p
->where
= gfc_current_locus
;
3267 p
->last_statement
= st
;
3272 gfc_error ("%s statement at %C cannot follow %s statement at %L",
3273 gfc_ascii_statement (st
),
3274 gfc_ascii_statement (p
->last_statement
), &p
->where
);
3280 /* Handle an unexpected end of file. This is a show-stopper... */
3282 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
3285 unexpected_eof (void)
3289 gfc_error ("Unexpected end of file in %qs", gfc_source_file
);
3291 /* Memory cleanup. Move to "second to last". */
3292 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
3295 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
3298 longjmp (eof_buf
, 1);
3300 /* Avoids build error on systems where longjmp is not declared noreturn. */
3305 /* Parse the CONTAINS section of a derived type definition. */
3307 gfc_access gfc_typebound_default_access
;
3310 parse_derived_contains (void)
3313 bool seen_private
= false;
3314 bool seen_comps
= false;
3315 bool error_flag
= false;
3318 gcc_assert (gfc_current_state () == COMP_DERIVED
);
3319 gcc_assert (gfc_current_block ());
3321 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
3323 if (gfc_current_block ()->attr
.sequence
)
3324 gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
3325 " section at %C", gfc_current_block ()->name
);
3326 if (gfc_current_block ()->attr
.is_bind_c
)
3327 gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
3328 " section at %C", gfc_current_block ()->name
);
3330 accept_statement (ST_CONTAINS
);
3331 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
3333 gfc_typebound_default_access
= ACCESS_PUBLIC
;
3339 st
= next_statement ();
3347 gfc_error ("Components in TYPE at %C must precede CONTAINS");
3351 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
3354 accept_statement (ST_PROCEDURE
);
3359 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
3362 accept_statement (ST_GENERIC
);
3367 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
3371 accept_statement (ST_FINAL
);
3379 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
3380 "at %C with empty CONTAINS section")))
3383 /* ST_END_TYPE is accepted by parse_derived after return. */
3387 if (!gfc_find_state (COMP_MODULE
))
3389 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3396 gfc_error ("PRIVATE statement at %C must precede procedure"
3403 gfc_error ("Duplicate PRIVATE statement at %C");
3407 accept_statement (ST_PRIVATE
);
3408 gfc_typebound_default_access
= ACCESS_PRIVATE
;
3409 seen_private
= true;
3413 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
3417 gfc_error ("Already inside a CONTAINS block at %C");
3421 unexpected_statement (st
);
3429 reject_statement ();
3433 gcc_assert (gfc_current_state () == COMP_DERIVED
);
3439 /* Set attributes for the parent symbol based on the attributes of a component
3440 and raise errors if conflicting attributes are found for the component. */
3443 check_component (gfc_symbol
*sym
, gfc_component
*c
, gfc_component
**lockp
,
3444 gfc_component
**eventp
)
3446 bool coarray
, lock_type
, event_type
, allocatable
, pointer
;
3447 coarray
= lock_type
= event_type
= allocatable
= pointer
= false;
3448 gfc_component
*lock_comp
= NULL
, *event_comp
= NULL
;
3450 if (lockp
) lock_comp
= *lockp
;
3451 if (eventp
) event_comp
= *eventp
;
3453 /* Look for allocatable components. */
3454 if (c
->attr
.allocatable
3455 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3456 && CLASS_DATA (c
)->attr
.allocatable
)
3457 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
3458 && c
->ts
.u
.derived
->attr
.alloc_comp
))
3461 sym
->attr
.alloc_comp
= 1;
3464 /* Look for pointer components. */
3466 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3467 && CLASS_DATA (c
)->attr
.class_pointer
)
3468 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
3471 sym
->attr
.pointer_comp
= 1;
3474 /* Look for procedure pointer components. */
3475 if (c
->attr
.proc_pointer
3476 || (c
->ts
.type
== BT_DERIVED
3477 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
3478 sym
->attr
.proc_pointer_comp
= 1;
3480 /* Looking for coarray components. */
3481 if (c
->attr
.codimension
3482 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3483 && CLASS_DATA (c
)->attr
.codimension
))
3486 sym
->attr
.coarray_comp
= 1;
3489 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
3490 && !c
->attr
.pointer
)
3493 sym
->attr
.coarray_comp
= 1;
3496 /* Looking for lock_type components. */
3497 if ((c
->ts
.type
== BT_DERIVED
3498 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3499 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3500 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3501 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
3502 == INTMOD_ISO_FORTRAN_ENV
3503 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
3504 == ISOFORTRAN_LOCK_TYPE
)
3505 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
3506 && !allocatable
&& !pointer
))
3510 sym
->attr
.lock_comp
= 1;
3513 /* Looking for event_type components. */
3514 if ((c
->ts
.type
== BT_DERIVED
3515 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3516 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
3517 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3518 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
3519 == INTMOD_ISO_FORTRAN_ENV
3520 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
3521 == ISOFORTRAN_EVENT_TYPE
)
3522 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.event_comp
3523 && !allocatable
&& !pointer
))
3527 sym
->attr
.event_comp
= 1;
3530 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
3531 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
3532 unless there are nondirect [allocatable or pointer] components
3533 involved (cf. 1.3.33.1 and 1.3.33.3). */
3535 if (pointer
&& !coarray
&& lock_type
)
3536 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
3537 "codimension or be a subcomponent of a coarray, "
3538 "which is not possible as the component has the "
3539 "pointer attribute", c
->name
, &c
->loc
);
3540 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
3541 && c
->ts
.u
.derived
->attr
.lock_comp
)
3542 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3543 "of type LOCK_TYPE, which must have a codimension or be a "
3544 "subcomponent of a coarray", c
->name
, &c
->loc
);
3546 if (lock_type
&& allocatable
&& !coarray
)
3547 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
3548 "a codimension", c
->name
, &c
->loc
);
3549 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
3550 && c
->ts
.u
.derived
->attr
.lock_comp
)
3551 gfc_error ("Allocatable component %s at %L must have a codimension as "
3552 "it has a noncoarray subcomponent of type LOCK_TYPE",
3555 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
3556 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3557 "subcomponent of type LOCK_TYPE must have a codimension or "
3558 "be a subcomponent of a coarray. (Variables of type %s may "
3559 "not have a codimension as already a coarray "
3560 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
3562 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
3563 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3564 "subcomponent of type LOCK_TYPE must have a codimension or "
3565 "be a subcomponent of a coarray. (Variables of type %s may "
3566 "not have a codimension as %s at %L has a codimension or a "
3567 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
3568 sym
->name
, c
->name
, &c
->loc
);
3570 /* Similarly for EVENT TYPE. */
3572 if (pointer
&& !coarray
&& event_type
)
3573 gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
3574 "codimension or be a subcomponent of a coarray, "
3575 "which is not possible as the component has the "
3576 "pointer attribute", c
->name
, &c
->loc
);
3577 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
3578 && c
->ts
.u
.derived
->attr
.event_comp
)
3579 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3580 "of type EVENT_TYPE, which must have a codimension or be a "
3581 "subcomponent of a coarray", c
->name
, &c
->loc
);
3583 if (event_type
&& allocatable
&& !coarray
)
3584 gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
3585 "a codimension", c
->name
, &c
->loc
);
3586 else if (event_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
3587 && c
->ts
.u
.derived
->attr
.event_comp
)
3588 gfc_error ("Allocatable component %s at %L must have a codimension as "
3589 "it has a noncoarray subcomponent of type EVENT_TYPE",
3592 if (sym
->attr
.coarray_comp
&& !coarray
&& event_type
)
3593 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3594 "subcomponent of type EVENT_TYPE must have a codimension or "
3595 "be a subcomponent of a coarray. (Variables of type %s may "
3596 "not have a codimension as already a coarray "
3597 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
3599 if (sym
->attr
.event_comp
&& coarray
&& !event_type
)
3600 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3601 "subcomponent of type EVENT_TYPE must have a codimension or "
3602 "be a subcomponent of a coarray. (Variables of type %s may "
3603 "not have a codimension as %s at %L has a codimension or a "
3604 "coarray subcomponent)", event_comp
->name
, &event_comp
->loc
,
3605 sym
->name
, c
->name
, &c
->loc
);
3607 /* Look for private components. */
3608 if (sym
->component_access
== ACCESS_PRIVATE
3609 || c
->attr
.access
== ACCESS_PRIVATE
3610 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
3611 sym
->attr
.private_comp
= 1;
3613 if (lockp
) *lockp
= lock_comp
;
3614 if (eventp
) *eventp
= event_comp
;
3618 static void parse_struct_map (gfc_statement
);
3620 /* Parse a union component definition within a structure definition. */
3628 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3631 accept_statement(ST_UNION
);
3632 push_state (&s
, COMP_UNION
, gfc_new_block
);
3639 st
= next_statement ();
3640 /* Only MAP declarations valid within a union. */
3647 accept_statement (ST_MAP
);
3648 parse_struct_map (ST_MAP
);
3649 /* Add a component to the union for each map. */
3650 if (!gfc_add_component (un
, gfc_new_block
->name
, &c
))
3652 gfc_internal_error ("failed to create map component '%s'",
3653 gfc_new_block
->name
);
3654 reject_statement ();
3657 c
->ts
.type
= BT_DERIVED
;
3658 c
->ts
.u
.derived
= gfc_new_block
;
3659 /* Normally components get their initialization expressions when they
3660 are created in decl.cc (build_struct) so we can look through the
3661 flat component list for initializers during resolution. Unions and
3662 maps create components along with their type definitions so we
3663 have to generate initializers here. */
3664 c
->initializer
= gfc_default_initializer (&c
->ts
);
3669 accept_statement (ST_END_UNION
);
3673 unexpected_statement (st
);
3678 for (c
= un
->components
; c
; c
= c
->next
)
3679 check_component (un
, c
, &lock_comp
, &event_comp
);
3681 /* Add the union as a component in its parent structure. */
3683 if (!gfc_add_component (gfc_current_block (), un
->name
, &c
))
3685 gfc_internal_error ("failed to create union component '%s'", un
->name
);
3686 reject_statement ();
3689 c
->ts
.type
= BT_UNION
;
3690 c
->ts
.u
.derived
= un
;
3691 c
->initializer
= gfc_default_initializer (&c
->ts
);
3693 un
->attr
.zero_comp
= un
->components
== NULL
;
3697 /* Parse a STRUCTURE or MAP. */
3700 parse_struct_map (gfc_statement block
)
3706 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3707 gfc_compile_state comp
;
3710 if (block
== ST_STRUCTURE_DECL
)
3712 comp
= COMP_STRUCTURE
;
3713 ends
= ST_END_STRUCTURE
;
3717 gcc_assert (block
== ST_MAP
);
3722 accept_statement(block
);
3723 push_state (&s
, comp
, gfc_new_block
);
3725 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3728 while (compiling_type
)
3730 st
= next_statement ();
3736 /* Nested structure declarations will be captured as ST_DATA_DECL. */
3737 case ST_STRUCTURE_DECL
:
3738 /* Let a more specific error make it to decode_statement(). */
3739 if (gfc_error_check () == 0)
3740 gfc_error ("Syntax error in nested structure declaration at %C");
3741 reject_statement ();
3742 /* Skip the rest of this statement. */
3743 gfc_error_recovery ();
3747 accept_statement (ST_UNION
);
3752 /* The data declaration was a nested/ad-hoc STRUCTURE field. */
3753 accept_statement (ST_DATA_DECL
);
3754 if (gfc_new_block
&& gfc_new_block
!= gfc_current_block ()
3755 && gfc_new_block
->attr
.flavor
== FL_STRUCT
)
3756 parse_struct_map (ST_STRUCTURE_DECL
);
3759 case ST_END_STRUCTURE
:
3763 accept_statement (st
);
3767 unexpected_statement (st
);
3771 unexpected_statement (st
);
3776 /* Validate each component. */
3777 sym
= gfc_current_block ();
3778 for (c
= sym
->components
; c
; c
= c
->next
)
3779 check_component (sym
, c
, &lock_comp
, &event_comp
);
3781 sym
->attr
.zero_comp
= (sym
->components
== NULL
);
3783 /* Allow parse_union to find this structure to add to its list of maps. */
3784 if (block
== ST_MAP
)
3785 gfc_new_block
= gfc_current_block ();
3791 /* Parse a derived type. */
3794 parse_derived (void)
3796 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
3800 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3802 accept_statement (ST_DERIVED_DECL
);
3803 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
3805 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3812 while (compiling_type
)
3814 st
= next_statement ();
3822 accept_statement (st
);
3827 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
3834 if (!seen_component
)
3835 gfc_notify_std (GFC_STD_F2003
, "Derived type "
3836 "definition at %C without components");
3838 accept_statement (ST_END_TYPE
);
3842 if (!gfc_find_state (COMP_MODULE
))
3844 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3851 gfc_error ("PRIVATE statement at %C must precede "
3852 "structure components");
3857 gfc_error ("Duplicate PRIVATE statement at %C");
3859 s
.sym
->component_access
= ACCESS_PRIVATE
;
3861 accept_statement (ST_PRIVATE
);
3868 gfc_error ("SEQUENCE statement at %C must precede "
3869 "structure components");
3873 if (gfc_current_block ()->attr
.sequence
)
3874 gfc_warning (0, "SEQUENCE attribute at %C already specified in "
3879 gfc_error ("Duplicate SEQUENCE statement at %C");
3883 gfc_add_sequence (&gfc_current_block ()->attr
,
3884 gfc_current_block ()->name
, NULL
);
3888 gfc_notify_std (GFC_STD_F2003
,
3889 "CONTAINS block in derived type"
3890 " definition at %C");
3892 accept_statement (ST_CONTAINS
);
3893 parse_derived_contains ();
3897 unexpected_statement (st
);
3902 /* need to verify that all fields of the derived type are
3903 * interoperable with C if the type is declared to be bind(c)
3905 sym
= gfc_current_block ();
3906 for (c
= sym
->components
; c
; c
= c
->next
)
3907 check_component (sym
, c
, &lock_comp
, &event_comp
);
3909 if (!seen_component
)
3910 sym
->attr
.zero_comp
= 1;
3916 /* Parse an ENUM. */
3924 int seen_enumerator
= 0;
3926 push_state (&s
, COMP_ENUM
, gfc_new_block
);
3930 while (compiling_enum
)
3932 st
= next_statement ();
3940 seen_enumerator
= 1;
3941 accept_statement (st
);
3946 if (!seen_enumerator
)
3947 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
3948 accept_statement (st
);
3952 gfc_free_enum_history ();
3953 unexpected_statement (st
);
3961 /* Parse an interface. We must be able to deal with the possibility
3962 of recursive interfaces. The parse_spec() subroutine is mutually
3963 recursive with parse_interface(). */
3965 static gfc_statement
parse_spec (gfc_statement
);
3968 parse_interface (void)
3970 gfc_compile_state new_state
= COMP_NONE
, current_state
;
3971 gfc_symbol
*prog_unit
, *sym
;
3972 gfc_interface_info save
;
3973 gfc_state_data s1
, s2
;
3976 accept_statement (ST_INTERFACE
);
3978 current_interface
.ns
= gfc_current_ns
;
3979 save
= current_interface
;
3981 sym
= (current_interface
.type
== INTERFACE_GENERIC
3982 || current_interface
.type
== INTERFACE_USER_OP
)
3983 ? gfc_new_block
: NULL
;
3985 push_state (&s1
, COMP_INTERFACE
, sym
);
3986 current_state
= COMP_NONE
;
3989 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
3991 st
= next_statement ();
3999 if (st
== ST_SUBROUTINE
)
4000 new_state
= COMP_SUBROUTINE
;
4001 else if (st
== ST_FUNCTION
)
4002 new_state
= COMP_FUNCTION
;
4003 if (gfc_new_block
->attr
.pointer
)
4005 gfc_new_block
->attr
.pointer
= 0;
4006 gfc_new_block
->attr
.proc_pointer
= 1;
4008 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
4009 gfc_new_block
->formal
, NULL
))
4011 reject_statement ();
4012 gfc_free_namespace (gfc_current_ns
);
4015 /* F2008 C1210 forbids the IMPORT statement in module procedure
4016 interface bodies and the flag is set to import symbols. */
4017 if (gfc_new_block
->attr
.module_procedure
)
4018 gfc_current_ns
->has_import_set
= 1;
4022 case ST_MODULE_PROC
: /* The module procedure matcher makes
4023 sure the context is correct. */
4024 accept_statement (st
);
4025 gfc_free_namespace (gfc_current_ns
);
4028 case ST_END_INTERFACE
:
4029 gfc_free_namespace (gfc_current_ns
);
4030 gfc_current_ns
= current_interface
.ns
;
4034 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
4035 gfc_ascii_statement (st
));
4036 reject_statement ();
4037 gfc_free_namespace (gfc_current_ns
);
4042 /* Make sure that the generic name has the right attribute. */
4043 if (current_interface
.type
== INTERFACE_GENERIC
4044 && current_state
== COMP_NONE
)
4046 if (new_state
== COMP_FUNCTION
&& sym
)
4047 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
4048 else if (new_state
== COMP_SUBROUTINE
&& sym
)
4049 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
4051 current_state
= new_state
;
4054 if (current_interface
.type
== INTERFACE_ABSTRACT
)
4056 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
4057 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
4058 gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
4059 "cannot be the same as an intrinsic type",
4060 gfc_new_block
->name
);
4063 push_state (&s2
, new_state
, gfc_new_block
);
4064 accept_statement (st
);
4065 prog_unit
= gfc_new_block
;
4066 prog_unit
->formal_ns
= gfc_current_ns
;
4069 /* Read data declaration statements. */
4070 st
= parse_spec (ST_NONE
);
4071 in_specification_block
= true;
4073 /* Since the interface block does not permit an IMPLICIT statement,
4074 the default type for the function or the result must be taken
4075 from the formal namespace. */
4076 if (new_state
== COMP_FUNCTION
)
4078 if (prog_unit
->result
== prog_unit
4079 && prog_unit
->ts
.type
== BT_UNKNOWN
)
4080 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
4081 else if (prog_unit
->result
!= prog_unit
4082 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
4083 gfc_set_default_type (prog_unit
->result
, 1,
4084 prog_unit
->formal_ns
);
4087 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
4089 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
4090 gfc_ascii_statement (st
));
4091 reject_statement ();
4095 /* Add EXTERNAL attribute to function or subroutine. */
4096 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
4097 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
4099 current_interface
= save
;
4100 gfc_add_interface (prog_unit
);
4103 if (current_interface
.ns
4104 && current_interface
.ns
->proc_name
4105 && strcmp (current_interface
.ns
->proc_name
->name
,
4106 prog_unit
->name
) == 0)
4107 gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
4108 "enclosing procedure", prog_unit
->name
,
4109 ¤t_interface
.ns
->proc_name
->declared_at
);
4118 /* Associate function characteristics by going back to the function
4119 declaration and rematching the prefix. */
4122 match_deferred_characteristics (gfc_typespec
* ts
)
4125 match m
= MATCH_ERROR
;
4126 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4128 loc
= gfc_current_locus
;
4130 gfc_current_locus
= gfc_current_block ()->declared_at
;
4133 gfc_buffer_error (true);
4134 m
= gfc_match_prefix (ts
);
4135 gfc_buffer_error (false);
4137 if (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
)
4145 /* Only permit one go at the characteristic association. */
4149 /* Set the function locus correctly. If we have not found the
4150 function name, there is an error. */
4152 && gfc_match ("function% %n", name
) == MATCH_YES
4153 && strcmp (name
, gfc_current_block ()->name
) == 0)
4155 gfc_current_block ()->declared_at
= gfc_current_locus
;
4156 gfc_commit_symbols ();
4161 gfc_undo_symbols ();
4164 gfc_current_locus
=loc
;
4169 /* Check specification-expressions in the function result of the currently
4170 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
4171 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
4172 scope are not yet parsed so this has to be delayed up to parse_spec. */
4175 check_function_result_typed (void)
4179 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
4181 if (!gfc_current_ns
->proc_name
->result
)
4184 ts
= gfc_current_ns
->proc_name
->result
->ts
;
4186 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
4187 /* TODO: Extend when KIND type parameters are implemented. */
4188 if (ts
.type
== BT_CHARACTER
&& ts
.u
.cl
&& ts
.u
.cl
->length
)
4190 /* Reject invalid type of specification expression for length. */
4191 if (ts
.u
.cl
->length
->ts
.type
!= BT_INTEGER
)
4194 gfc_expr_check_typed (ts
.u
.cl
->length
, gfc_current_ns
, true);
4201 /* Parse a set of specification statements. Returns the statement
4202 that doesn't fit. */
4204 static gfc_statement
4205 parse_spec (gfc_statement st
)
4208 bool function_result_typed
= false;
4209 bool bad_characteristic
= false;
4212 in_specification_block
= true;
4214 verify_st_order (&ss
, ST_NONE
, false);
4216 st
= next_statement ();
4218 /* If we are not inside a function or don't have a result specified so far,
4219 do nothing special about it. */
4220 if (gfc_current_state () != COMP_FUNCTION
)
4221 function_result_typed
= true;
4224 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
4227 if (proc
->result
&& proc
->result
->ts
.type
== BT_UNKNOWN
)
4228 function_result_typed
= true;
4233 /* If we're inside a BLOCK construct, some statements are disallowed.
4234 Check this here. Attribute declaration statements like INTENT, OPTIONAL
4235 or VALUE are also disallowed, but they don't have a particular ST_*
4236 key so we have to check for them individually in their matcher routine. */
4237 if (gfc_current_state () == COMP_BLOCK
)
4241 case ST_IMPLICIT_NONE
:
4244 case ST_EQUIVALENCE
:
4245 case ST_STATEMENT_FUNCTION
:
4246 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
4247 gfc_ascii_statement (st
));
4248 reject_statement ();
4254 else if (gfc_current_state () == COMP_BLOCK_DATA
)
4255 /* Fortran 2008, C1116. */
4262 case ST_DERIVED_DECL
:
4263 case ST_END_BLOCK_DATA
:
4264 case ST_EQUIVALENCE
:
4266 case ST_IMPLICIT_NONE
:
4267 case ST_OMP_THREADPRIVATE
:
4269 case ST_STRUCTURE_DECL
:
4278 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
4279 gfc_ascii_statement (st
));
4280 reject_statement ();
4284 /* If we find a statement that cannot be followed by an IMPLICIT statement
4285 (and thus we can expect to see none any further), type the function result
4286 if it has not yet been typed. Be careful not to give the END statement
4287 to verify_st_order! */
4288 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
4290 bool verify_now
= false;
4292 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
4297 verify_st_order (&dummyss
, ST_NONE
, false);
4298 verify_st_order (&dummyss
, st
, false);
4300 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
4305 function_result_typed
= check_function_result_typed ();
4313 case ST_IMPLICIT_NONE
:
4315 if (!function_result_typed
)
4316 function_result_typed
= check_function_result_typed ();
4321 case ST_DATA
: /* Not allowed in interfaces */
4322 if (gfc_current_state () == COMP_INTERFACE
)
4332 case ST_STRUCTURE_DECL
:
4333 case ST_DERIVED_DECL
:
4337 if (!verify_st_order (&ss
, st
, false))
4339 reject_statement ();
4340 st
= next_statement ();
4350 case ST_STRUCTURE_DECL
:
4351 parse_struct_map (ST_STRUCTURE_DECL
);
4354 case ST_DERIVED_DECL
:
4360 if (gfc_current_state () != COMP_MODULE
)
4362 gfc_error ("%s statement must appear in a MODULE",
4363 gfc_ascii_statement (st
));
4364 reject_statement ();
4368 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
4370 gfc_error ("%s statement at %C follows another accessibility "
4371 "specification", gfc_ascii_statement (st
));
4372 reject_statement ();
4376 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
4377 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
4381 case ST_STATEMENT_FUNCTION
:
4382 if (gfc_current_state () == COMP_MODULE
4383 || gfc_current_state () == COMP_SUBMODULE
)
4385 unexpected_statement (st
);
4393 accept_statement (st
);
4394 st
= next_statement ();
4398 accept_statement (st
);
4400 st
= next_statement ();
4403 case ST_GET_FCN_CHARACTERISTICS
:
4404 /* This statement triggers the association of a function's result
4406 ts
= &gfc_current_block ()->result
->ts
;
4407 if (match_deferred_characteristics (ts
) != MATCH_YES
)
4408 bad_characteristic
= true;
4410 st
= next_statement ();
4417 /* If match_deferred_characteristics failed, then there is an error. */
4418 if (bad_characteristic
)
4420 ts
= &gfc_current_block ()->result
->ts
;
4421 if (ts
->type
!= BT_DERIVED
&& ts
->type
!= BT_CLASS
)
4422 gfc_error ("Bad kind expression for function %qs at %L",
4423 gfc_current_block ()->name
,
4424 &gfc_current_block ()->declared_at
);
4426 gfc_error ("The type for function %qs at %L is not accessible",
4427 gfc_current_block ()->name
,
4428 &gfc_current_block ()->declared_at
);
4430 gfc_current_block ()->ts
.kind
= 0;
4431 /* Keep the derived type; if it's bad, it will be discovered later. */
4432 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
4433 ts
->type
= BT_UNKNOWN
;
4436 in_specification_block
= false;
4442 /* Parse a WHERE block, (not a simple WHERE statement). */
4445 parse_where_block (void)
4447 int seen_empty_else
;
4452 accept_statement (ST_WHERE_BLOCK
);
4453 top
= gfc_state_stack
->tail
;
4455 push_state (&s
, COMP_WHERE
, gfc_new_block
);
4457 d
= add_statement ();
4458 d
->expr1
= top
->expr1
;
4464 seen_empty_else
= 0;
4468 st
= next_statement ();
4474 case ST_WHERE_BLOCK
:
4475 parse_where_block ();
4480 accept_statement (st
);
4484 if (seen_empty_else
)
4486 gfc_error ("ELSEWHERE statement at %C follows previous "
4487 "unmasked ELSEWHERE");
4488 reject_statement ();
4492 if (new_st
.expr1
== NULL
)
4493 seen_empty_else
= 1;
4495 d
= new_level (gfc_state_stack
->head
);
4497 d
->expr1
= new_st
.expr1
;
4499 accept_statement (st
);
4504 accept_statement (st
);
4508 gfc_error ("Unexpected %s statement in WHERE block at %C",
4509 gfc_ascii_statement (st
));
4510 reject_statement ();
4514 while (st
!= ST_END_WHERE
);
4520 /* Parse a FORALL block (not a simple FORALL statement). */
4523 parse_forall_block (void)
4529 accept_statement (ST_FORALL_BLOCK
);
4530 top
= gfc_state_stack
->tail
;
4532 push_state (&s
, COMP_FORALL
, gfc_new_block
);
4534 d
= add_statement ();
4535 d
->op
= EXEC_FORALL
;
4540 st
= next_statement ();
4545 case ST_POINTER_ASSIGNMENT
:
4548 accept_statement (st
);
4551 case ST_WHERE_BLOCK
:
4552 parse_where_block ();
4555 case ST_FORALL_BLOCK
:
4556 parse_forall_block ();
4560 accept_statement (st
);
4567 gfc_error ("Unexpected %s statement in FORALL block at %C",
4568 gfc_ascii_statement (st
));
4570 reject_statement ();
4574 while (st
!= ST_END_FORALL
);
4580 static gfc_statement
parse_executable (gfc_statement
);
4582 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
4585 parse_if_block (void)
4594 accept_statement (ST_IF_BLOCK
);
4596 top
= gfc_state_stack
->tail
;
4597 push_state (&s
, COMP_IF
, gfc_new_block
);
4599 new_st
.op
= EXEC_IF
;
4600 d
= add_statement ();
4602 d
->expr1
= top
->expr1
;
4608 st
= parse_executable (ST_NONE
);
4618 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
4619 "statement at %L", &else_locus
);
4621 reject_statement ();
4625 d
= new_level (gfc_state_stack
->head
);
4627 d
->expr1
= new_st
.expr1
;
4629 accept_statement (st
);
4636 gfc_error ("Duplicate ELSE statements at %L and %C",
4638 reject_statement ();
4643 else_locus
= gfc_current_locus
;
4645 d
= new_level (gfc_state_stack
->head
);
4648 accept_statement (st
);
4656 unexpected_statement (st
);
4660 while (st
!= ST_ENDIF
);
4663 accept_statement (st
);
4667 /* Parse a SELECT block. */
4670 parse_select_block (void)
4676 accept_statement (ST_SELECT_CASE
);
4678 cp
= gfc_state_stack
->tail
;
4679 push_state (&s
, COMP_SELECT
, gfc_new_block
);
4681 /* Make sure that the next statement is a CASE or END SELECT. */
4684 st
= next_statement ();
4687 if (st
== ST_END_SELECT
)
4689 /* Empty SELECT CASE is OK. */
4690 accept_statement (st
);
4697 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
4700 reject_statement ();
4703 /* At this point, we've got a nonempty select block. */
4704 cp
= new_level (cp
);
4707 accept_statement (st
);
4711 st
= parse_executable (ST_NONE
);
4718 cp
= new_level (gfc_state_stack
->head
);
4720 gfc_clear_new_st ();
4722 accept_statement (st
);
4728 /* Can't have an executable statement because of
4729 parse_executable(). */
4731 unexpected_statement (st
);
4735 while (st
!= ST_END_SELECT
);
4738 accept_statement (st
);
4742 /* Pop the current selector from the SELECT TYPE stack. */
4745 select_type_pop (void)
4747 gfc_select_type_stack
*old
= select_type_stack
;
4748 select_type_stack
= old
->prev
;
4753 /* Parse a SELECT TYPE construct (F03:R821). */
4756 parse_select_type_block (void)
4762 gfc_current_ns
= new_st
.ext
.block
.ns
;
4763 accept_statement (ST_SELECT_TYPE
);
4765 cp
= gfc_state_stack
->tail
;
4766 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
4768 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
4772 st
= next_statement ();
4775 if (st
== ST_END_SELECT
)
4776 /* Empty SELECT CASE is OK. */
4778 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
4781 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
4782 "following SELECT TYPE at %C");
4784 reject_statement ();
4787 /* At this point, we've got a nonempty select block. */
4788 cp
= new_level (cp
);
4791 accept_statement (st
);
4795 st
= parse_executable (ST_NONE
);
4803 cp
= new_level (gfc_state_stack
->head
);
4805 gfc_clear_new_st ();
4807 accept_statement (st
);
4813 /* Can't have an executable statement because of
4814 parse_executable(). */
4816 unexpected_statement (st
);
4820 while (st
!= ST_END_SELECT
);
4824 accept_statement (st
);
4825 gfc_current_ns
= gfc_current_ns
->parent
;
4830 /* Parse a SELECT RANK construct. */
4833 parse_select_rank_block (void)
4839 gfc_current_ns
= new_st
.ext
.block
.ns
;
4840 accept_statement (ST_SELECT_RANK
);
4842 cp
= gfc_state_stack
->tail
;
4843 push_state (&s
, COMP_SELECT_RANK
, gfc_new_block
);
4845 /* Make sure that the next statement is a RANK IS or RANK DEFAULT. */
4848 st
= next_statement ();
4851 if (st
== ST_END_SELECT
)
4852 /* Empty SELECT CASE is OK. */
4857 gfc_error ("Expected RANK or RANK DEFAULT "
4858 "following SELECT RANK at %C");
4860 reject_statement ();
4863 /* At this point, we've got a nonempty select block. */
4864 cp
= new_level (cp
);
4867 accept_statement (st
);
4871 st
= parse_executable (ST_NONE
);
4878 cp
= new_level (gfc_state_stack
->head
);
4880 gfc_clear_new_st ();
4882 accept_statement (st
);
4888 /* Can't have an executable statement because of
4889 parse_executable(). */
4891 unexpected_statement (st
);
4895 while (st
!= ST_END_SELECT
);
4899 accept_statement (st
);
4900 gfc_current_ns
= gfc_current_ns
->parent
;
4905 /* Given a symbol, make sure it is not an iteration variable for a DO
4906 statement. This subroutine is called when the symbol is seen in a
4907 context that causes it to become redefined. If the symbol is an
4908 iterator, we generate an error message and return nonzero. */
4911 gfc_check_do_variable (gfc_symtree
*st
)
4918 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
4919 if (s
->do_variable
== st
)
4921 gfc_error_now ("Variable %qs at %C cannot be redefined inside "
4922 "loop beginning at %L", st
->name
, &s
->head
->loc
);
4930 /* Checks to see if the current statement label closes an enddo.
4931 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
4932 an error) if it incorrectly closes an ENDDO. */
4935 check_do_closure (void)
4939 if (gfc_statement_label
== NULL
)
4942 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
4943 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4947 return 0; /* No loops to close */
4949 if (p
->ext
.end_do_label
== gfc_statement_label
)
4951 if (p
== gfc_state_stack
)
4954 gfc_error ("End of nonblock DO statement at %C is within another block");
4958 /* At this point, the label doesn't terminate the innermost loop.
4959 Make sure it doesn't terminate another one. */
4960 for (; p
; p
= p
->previous
)
4961 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4962 && p
->ext
.end_do_label
== gfc_statement_label
)
4964 gfc_error ("End of nonblock DO statement at %C is interwoven "
4965 "with another DO loop");
4973 /* Parse a series of contained program units. */
4975 static void parse_progunit (gfc_statement
);
4978 /* Parse a CRITICAL block. */
4981 parse_critical_block (void)
4984 gfc_state_data s
, *sd
;
4987 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4988 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
4989 gfc_error_now (is_oacc (sd
)
4990 ? G_("CRITICAL block inside of OpenACC region at %C")
4991 : G_("CRITICAL block inside of OpenMP region at %C"));
4993 s
.ext
.end_do_label
= new_st
.label1
;
4995 accept_statement (ST_CRITICAL
);
4996 top
= gfc_state_stack
->tail
;
4998 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
5000 d
= add_statement ();
5001 d
->op
= EXEC_CRITICAL
;
5006 st
= parse_executable (ST_NONE
);
5014 case ST_END_CRITICAL
:
5015 if (s
.ext
.end_do_label
!= NULL
5016 && s
.ext
.end_do_label
!= gfc_statement_label
)
5017 gfc_error_now ("Statement label in END CRITICAL at %C does not "
5018 "match CRITICAL label");
5020 if (gfc_statement_label
!= NULL
)
5022 new_st
.op
= EXEC_NOP
;
5028 unexpected_statement (st
);
5032 while (st
!= ST_END_CRITICAL
);
5035 accept_statement (st
);
5039 /* Set up the local namespace for a BLOCK construct. */
5042 gfc_build_block_ns (gfc_namespace
*parent_ns
)
5044 gfc_namespace
* my_ns
;
5045 static int numblock
= 1;
5047 my_ns
= gfc_get_namespace (parent_ns
, 1);
5048 my_ns
->construct_entities
= 1;
5050 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
5051 code generation (so it must not be NULL).
5052 We set its recursive argument if our container procedure is recursive, so
5053 that local variables are accordingly placed on the stack when it
5054 will be necessary. */
5056 my_ns
->proc_name
= gfc_new_block
;
5060 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
5062 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
5063 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
5064 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
5065 my_ns
->proc_name
->name
, NULL
);
5067 gfc_commit_symbol (my_ns
->proc_name
);
5070 if (parent_ns
->proc_name
)
5071 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
5077 /* Parse a BLOCK construct. */
5080 parse_block_construct (void)
5082 gfc_namespace
* my_ns
;
5083 gfc_namespace
* my_parent
;
5086 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
5088 my_ns
= gfc_build_block_ns (gfc_current_ns
);
5090 new_st
.op
= EXEC_BLOCK
;
5091 new_st
.ext
.block
.ns
= my_ns
;
5092 new_st
.ext
.block
.assoc
= NULL
;
5093 accept_statement (ST_BLOCK
);
5095 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
5096 gfc_current_ns
= my_ns
;
5097 my_parent
= my_ns
->parent
;
5099 parse_progunit (ST_NONE
);
5101 /* Don't depend on the value of gfc_current_ns; it might have been
5102 reset if the block had errors and was cleaned up. */
5103 gfc_current_ns
= my_parent
;
5109 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
5110 behind the scenes with compiler-generated variables. */
5113 parse_associate (void)
5115 gfc_namespace
* my_ns
;
5118 gfc_association_list
* a
;
5121 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
5123 my_ns
= gfc_build_block_ns (gfc_current_ns
);
5125 new_st
.op
= EXEC_BLOCK
;
5126 new_st
.ext
.block
.ns
= my_ns
;
5127 gcc_assert (new_st
.ext
.block
.assoc
);
5129 /* Add all associate-names as BLOCK variables. Creating them is enough
5130 for now, they'll get their values during trans-* phase. */
5131 gfc_current_ns
= my_ns
;
5132 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
5138 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
5142 sym
->attr
.flavor
= FL_VARIABLE
;
5144 sym
->declared_at
= a
->where
;
5145 gfc_set_sym_referenced (sym
);
5147 /* Initialize the typespec. It is not available in all cases,
5148 however, as it may only be set on the target during resolution.
5149 Still, sometimes it helps to have it right now -- especially
5150 for parsing component references on the associate-name
5151 in case of association to a derived-type. */
5152 sym
->ts
= a
->target
->ts
;
5155 /* Don’t share the character length information between associate
5156 variable and target if the length is not a compile-time constant,
5157 as we don’t want to touch some other character length variable when
5158 we try to initialize the associate variable’s character length
5160 We do it here rather than later so that expressions referencing the
5161 associate variable will automatically have the correctly setup length
5162 information. If we did it at resolution stage the expressions would
5163 use the original length information, and the variable a new different
5164 one, but only the latter one would be correctly initialized at
5165 translation stage, and the former one would need some additional setup
5167 if (sym
->ts
.type
== BT_CHARACTER
5169 && !(sym
->ts
.u
.cl
->length
5170 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
))
5171 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5173 /* Check if the target expression is array valued. This cannot be done
5174 by calling gfc_resolve_expr because the context is unavailable.
5175 However, the references can be resolved and the rank of the target
5177 if (target
->ref
&& gfc_resolve_ref (target
)
5178 && target
->expr_type
!= EXPR_ARRAY
5179 && target
->expr_type
!= EXPR_COMPCALL
)
5180 gfc_expression_rank (target
);
5182 /* Determine whether or not function expressions with unknown type are
5183 structure constructors. If so, the function result can be converted
5184 to be a derived type.
5185 TODO: Deal with references to sibling functions that have not yet been
5186 parsed (PRs 89645 and 99065). */
5187 if (target
->expr_type
== EXPR_FUNCTION
&& target
->ts
.type
== BT_UNKNOWN
)
5189 gfc_symbol
*derived
;
5190 /* The derived type has a leading uppercase character. */
5191 gfc_find_symbol (gfc_dt_upper_string (target
->symtree
->name
),
5192 my_ns
->parent
, 1, &derived
);
5193 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
5195 sym
->ts
.type
= BT_DERIVED
;
5196 sym
->ts
.u
.derived
= derived
;
5200 rank
= target
->rank
;
5201 /* Fixup cases where the ranks are mismatched. */
5202 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
5204 if ((!CLASS_DATA (sym
)->as
&& rank
!= 0)
5205 || (CLASS_DATA (sym
)->as
5206 && CLASS_DATA (sym
)->as
->rank
!= rank
))
5208 /* Don't just (re-)set the attr and as in the sym.ts,
5209 because this modifies the target's attr and as. Copy the
5210 data and do a build_class_symbol. */
5211 symbol_attribute attr
= CLASS_DATA (target
)->attr
;
5212 int corank
= gfc_get_corank (target
);
5217 as
= gfc_get_array_spec ();
5218 as
->type
= AS_DEFERRED
;
5220 as
->corank
= corank
;
5221 attr
.dimension
= rank
? 1 : 0;
5222 attr
.codimension
= corank
? 1 : 0;
5227 attr
.dimension
= attr
.codimension
= 0;
5230 type
= CLASS_DATA (sym
)->ts
;
5231 if (!gfc_build_class_symbol (&type
, &attr
, &as
))
5234 sym
->ts
.type
= BT_CLASS
;
5235 sym
->attr
.class_ok
= 1;
5238 sym
->attr
.class_ok
= 1;
5240 else if ((!sym
->as
&& rank
!= 0)
5241 || (sym
->as
&& sym
->as
->rank
!= rank
))
5243 as
= gfc_get_array_spec ();
5244 as
->type
= AS_DEFERRED
;
5246 as
->corank
= gfc_get_corank (target
);
5248 sym
->attr
.dimension
= 1;
5250 sym
->attr
.codimension
= 1;
5254 accept_statement (ST_ASSOCIATE
);
5255 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
5258 st
= parse_executable (ST_NONE
);
5265 accept_statement (st
);
5266 my_ns
->code
= gfc_state_stack
->head
;
5270 unexpected_statement (st
);
5274 gfc_current_ns
= gfc_current_ns
->parent
;
5279 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
5280 handled inside of parse_executable(), because they aren't really
5284 parse_do_block (void)
5293 s
.ext
.end_do_label
= new_st
.label1
;
5295 if (new_st
.ext
.iterator
!= NULL
)
5297 stree
= new_st
.ext
.iterator
->var
->symtree
;
5298 if (directive_unroll
!= -1)
5300 new_st
.ext
.iterator
->unroll
= directive_unroll
;
5301 directive_unroll
= -1;
5303 if (directive_ivdep
)
5305 new_st
.ext
.iterator
->ivdep
= directive_ivdep
;
5306 directive_ivdep
= false;
5308 if (directive_vector
)
5310 new_st
.ext
.iterator
->vector
= directive_vector
;
5311 directive_vector
= false;
5313 if (directive_novector
)
5315 new_st
.ext
.iterator
->novector
= directive_novector
;
5316 directive_novector
= false;
5322 accept_statement (ST_DO
);
5324 top
= gfc_state_stack
->tail
;
5325 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
5328 s
.do_variable
= stree
;
5330 top
->block
= new_level (top
);
5331 top
->block
->op
= EXEC_DO
;
5334 st
= parse_executable (ST_NONE
);
5342 if (s
.ext
.end_do_label
!= NULL
5343 && s
.ext
.end_do_label
!= gfc_statement_label
)
5344 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
5347 if (gfc_statement_label
!= NULL
)
5349 new_st
.op
= EXEC_NOP
;
5354 case ST_IMPLIED_ENDDO
:
5355 /* If the do-stmt of this DO construct has a do-construct-name,
5356 the corresponding end-do must be an end-do-stmt (with a matching
5357 name, but in that case we must have seen ST_ENDDO first).
5358 We only complain about this in pedantic mode. */
5359 if (gfc_current_block () != NULL
)
5360 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
5361 &gfc_current_block()->declared_at
);
5366 unexpected_statement (st
);
5371 accept_statement (st
);
5375 /* Parse the statements of OpenMP do/parallel do. */
5377 static gfc_statement
5378 parse_omp_do (gfc_statement omp_st
)
5384 accept_statement (omp_st
);
5386 cp
= gfc_state_stack
->tail
;
5387 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5388 np
= new_level (cp
);
5394 st
= next_statement ();
5397 else if (st
== ST_DO
)
5400 unexpected_statement (st
);
5404 if (gfc_statement_label
!= NULL
5405 && gfc_state_stack
->previous
!= NULL
5406 && gfc_state_stack
->previous
->state
== COMP_DO
5407 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
5415 there should be no !$OMP END DO. */
5417 return ST_IMPLIED_ENDDO
;
5420 check_do_closure ();
5423 st
= next_statement ();
5424 gfc_statement omp_end_st
= ST_OMP_END_DO
;
5427 case ST_OMP_DISTRIBUTE
: omp_end_st
= ST_OMP_END_DISTRIBUTE
; break;
5428 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5429 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
5431 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5432 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
5434 case ST_OMP_DISTRIBUTE_SIMD
:
5435 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
5437 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
5438 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
5439 case ST_OMP_LOOP
: omp_end_st
= ST_OMP_END_LOOP
; break;
5440 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
5441 case ST_OMP_PARALLEL_DO_SIMD
:
5442 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
5444 case ST_OMP_PARALLEL_LOOP
:
5445 omp_end_st
= ST_OMP_END_PARALLEL_LOOP
;
5447 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
5448 case ST_OMP_TARGET_PARALLEL_DO
:
5449 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO
;
5451 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
5452 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO_SIMD
;
5454 case ST_OMP_TARGET_PARALLEL_LOOP
:
5455 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_LOOP
;
5457 case ST_OMP_TARGET_SIMD
: omp_end_st
= ST_OMP_END_TARGET_SIMD
; break;
5458 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5459 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
5461 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5462 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5464 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5465 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5467 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5468 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
5470 case ST_OMP_TARGET_TEAMS_LOOP
:
5471 omp_end_st
= ST_OMP_END_TARGET_TEAMS_LOOP
;
5473 case ST_OMP_TASKLOOP
: omp_end_st
= ST_OMP_END_TASKLOOP
; break;
5474 case ST_OMP_TASKLOOP_SIMD
: omp_end_st
= ST_OMP_END_TASKLOOP_SIMD
; break;
5475 case ST_OMP_MASKED_TASKLOOP
: omp_end_st
= ST_OMP_END_MASKED_TASKLOOP
; break;
5476 case ST_OMP_MASKED_TASKLOOP_SIMD
:
5477 omp_end_st
= ST_OMP_END_MASKED_TASKLOOP_SIMD
;
5479 case ST_OMP_MASTER_TASKLOOP
: omp_end_st
= ST_OMP_END_MASTER_TASKLOOP
; break;
5480 case ST_OMP_MASTER_TASKLOOP_SIMD
:
5481 omp_end_st
= ST_OMP_END_MASTER_TASKLOOP_SIMD
;
5483 case ST_OMP_PARALLEL_MASKED_TASKLOOP
:
5484 omp_end_st
= ST_OMP_END_PARALLEL_MASKED_TASKLOOP
;
5486 case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
5487 omp_end_st
= ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD
;
5489 case ST_OMP_PARALLEL_MASTER_TASKLOOP
:
5490 omp_end_st
= ST_OMP_END_PARALLEL_MASTER_TASKLOOP
;
5492 case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
5493 omp_end_st
= ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD
;
5495 case ST_OMP_TEAMS_DISTRIBUTE
:
5496 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
5498 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5499 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5501 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5502 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5504 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5505 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
5507 case ST_OMP_TEAMS_LOOP
:
5508 omp_end_st
= ST_OMP_END_TEAMS_LOOP
;
5510 default: gcc_unreachable ();
5512 if (st
== omp_end_st
)
5514 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
5516 if (cp
->ext
.omp_clauses
->nowait
&& new_st
.ext
.omp_bool
)
5517 gfc_error_now ("Duplicated NOWAIT clause on %s and %s at %C",
5518 gfc_ascii_statement (omp_st
),
5519 gfc_ascii_statement (omp_end_st
));
5520 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
5523 gcc_assert (new_st
.op
== EXEC_NOP
);
5524 gfc_clear_new_st ();
5525 gfc_commit_symbols ();
5526 gfc_warning_check ();
5527 st
= next_statement ();
5533 /* Parse the statements of OpenMP atomic directive. */
5535 static gfc_statement
5536 parse_omp_oacc_atomic (bool omp_p
)
5538 gfc_statement st
, st_atomic
, st_end_atomic
;
5545 st_atomic
= ST_OMP_ATOMIC
;
5546 st_end_atomic
= ST_OMP_END_ATOMIC
;
5550 st_atomic
= ST_OACC_ATOMIC
;
5551 st_end_atomic
= ST_OACC_END_ATOMIC
;
5553 accept_statement (st_atomic
);
5555 cp
= gfc_state_stack
->tail
;
5556 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5557 np
= new_level (cp
);
5560 np
->ext
.omp_clauses
= cp
->ext
.omp_clauses
;
5561 cp
->ext
.omp_clauses
= NULL
;
5562 count
= 1 + np
->ext
.omp_clauses
->capture
;
5566 st
= next_statement ();
5569 else if (np
->ext
.omp_clauses
->compare
5570 && (st
== ST_SIMPLE_IF
|| st
== ST_IF_BLOCK
))
5573 if (st
== ST_IF_BLOCK
)
5576 /* With else (or elseif). */
5577 if (gfc_state_stack
->tail
->block
->block
)
5580 accept_statement (st
);
5582 else if (st
== ST_ASSIGNMENT
5583 && (!np
->ext
.omp_clauses
->compare
5584 || np
->ext
.omp_clauses
->capture
))
5586 accept_statement (st
);
5590 unexpected_statement (st
);
5595 st
= next_statement ();
5596 if (st
== st_end_atomic
)
5598 gfc_clear_new_st ();
5599 gfc_commit_symbols ();
5600 gfc_warning_check ();
5601 st
= next_statement ();
5607 /* Parse the statements of an OpenACC structured block. */
5610 parse_oacc_structured_block (gfc_statement acc_st
)
5612 gfc_statement st
, acc_end_st
;
5614 gfc_state_data s
, *sd
;
5616 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
5617 if (sd
->state
== COMP_CRITICAL
)
5618 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5620 accept_statement (acc_st
);
5622 cp
= gfc_state_stack
->tail
;
5623 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5624 np
= new_level (cp
);
5629 case ST_OACC_PARALLEL
:
5630 acc_end_st
= ST_OACC_END_PARALLEL
;
5632 case ST_OACC_KERNELS
:
5633 acc_end_st
= ST_OACC_END_KERNELS
;
5635 case ST_OACC_SERIAL
:
5636 acc_end_st
= ST_OACC_END_SERIAL
;
5639 acc_end_st
= ST_OACC_END_DATA
;
5641 case ST_OACC_HOST_DATA
:
5642 acc_end_st
= ST_OACC_END_HOST_DATA
;
5650 st
= parse_executable (ST_NONE
);
5653 else if (st
!= acc_end_st
)
5655 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
5656 reject_statement ();
5659 while (st
!= acc_end_st
);
5661 gcc_assert (new_st
.op
== EXEC_NOP
);
5663 gfc_clear_new_st ();
5664 gfc_commit_symbols ();
5665 gfc_warning_check ();
5669 /* Parse the statements of OpenACC 'loop', or combined compute 'loop'. */
5671 static gfc_statement
5672 parse_oacc_loop (gfc_statement acc_st
)
5676 gfc_state_data s
, *sd
;
5678 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
5679 if (sd
->state
== COMP_CRITICAL
)
5680 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5682 accept_statement (acc_st
);
5684 cp
= gfc_state_stack
->tail
;
5685 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5686 np
= new_level (cp
);
5692 st
= next_statement ();
5695 else if (st
== ST_DO
)
5699 gfc_error ("Expected DO loop at %C");
5700 reject_statement ();
5705 if (gfc_statement_label
!= NULL
5706 && gfc_state_stack
->previous
!= NULL
5707 && gfc_state_stack
->previous
->state
== COMP_DO
5708 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
5711 return ST_IMPLIED_ENDDO
;
5714 check_do_closure ();
5717 st
= next_statement ();
5718 if (st
== ST_OACC_END_LOOP
)
5719 gfc_warning (0, "Redundant !$ACC END LOOP at %C");
5720 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
5721 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
5722 (acc_st
== ST_OACC_SERIAL_LOOP
&& st
== ST_OACC_END_SERIAL_LOOP
) ||
5723 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
5725 gcc_assert (new_st
.op
== EXEC_NOP
);
5726 gfc_clear_new_st ();
5727 gfc_commit_symbols ();
5728 gfc_warning_check ();
5729 st
= next_statement ();
5735 /* Parse an OpenMP allocate block, including optional ALLOCATORS
5738 static gfc_statement
5739 parse_openmp_allocate_block (gfc_statement omp_st
)
5744 bool empty_list
= false;
5745 locus empty_list_loc
;
5746 gfc_omp_namelist
*n_first
= new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
];
5748 if (omp_st
== ST_OMP_ALLOCATE_EXEC
5749 && new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->sym
== NULL
)
5752 empty_list_loc
= new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->where
;
5755 accept_statement (omp_st
);
5757 cp
= gfc_state_stack
->tail
;
5758 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5759 np
= new_level (cp
);
5763 st
= next_statement ();
5764 while (omp_st
== ST_OMP_ALLOCATE_EXEC
&& st
== ST_OMP_ALLOCATE_EXEC
)
5766 if (empty_list
&& !new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->sym
)
5768 locus
*loc
= &new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->where
;
5769 gfc_error_now ("%s statements at %L and %L have both no list item but"
5770 " only one may", gfc_ascii_statement (st
),
5771 &empty_list_loc
, loc
);
5774 if (!new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->sym
)
5777 empty_list_loc
= new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->where
;
5779 for ( ; n_first
->next
; n_first
= n_first
->next
)
5781 n_first
->next
= new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
];
5782 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
] = NULL
;
5783 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
5785 accept_statement (ST_NONE
);
5786 st
= next_statement ();
5788 if (st
!= ST_ALLOCATE
&& omp_st
== ST_OMP_ALLOCATE_EXEC
)
5789 gfc_error_now ("Unexpected %s at %C; expected ALLOCATE or %s statement",
5790 gfc_ascii_statement (st
), gfc_ascii_statement (omp_st
));
5791 else if (st
!= ST_ALLOCATE
)
5792 gfc_error_now ("Unexpected %s at %C; expected ALLOCATE statement after %s",
5793 gfc_ascii_statement (st
), gfc_ascii_statement (omp_st
));
5794 accept_statement (st
);
5796 st
= next_statement ();
5797 if (omp_st
== ST_OMP_ALLOCATORS
&& st
== ST_OMP_END_ALLOCATORS
)
5799 accept_statement (st
);
5800 st
= next_statement ();
5806 /* Parse the statements of an OpenMP structured block. */
5808 static gfc_statement
5809 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
5811 gfc_statement st
, omp_end_st
, first_st
;
5813 gfc_state_data s
, s2
;
5815 accept_statement (omp_st
);
5817 cp
= gfc_state_stack
->tail
;
5818 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5819 np
= new_level (cp
);
5826 omp_end_st
= ST_OMP_END_ASSUME
;
5828 case ST_OMP_PARALLEL
:
5829 omp_end_st
= ST_OMP_END_PARALLEL
;
5831 case ST_OMP_PARALLEL_MASKED
:
5832 omp_end_st
= ST_OMP_END_PARALLEL_MASKED
;
5834 case ST_OMP_PARALLEL_MASTER
:
5835 omp_end_st
= ST_OMP_END_PARALLEL_MASTER
;
5837 case ST_OMP_PARALLEL_SECTIONS
:
5838 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
5841 omp_end_st
= ST_OMP_END_SCOPE
;
5843 case ST_OMP_SECTIONS
:
5844 omp_end_st
= ST_OMP_END_SECTIONS
;
5846 case ST_OMP_ORDERED
:
5847 omp_end_st
= ST_OMP_END_ORDERED
;
5849 case ST_OMP_CRITICAL
:
5850 omp_end_st
= ST_OMP_END_CRITICAL
;
5853 omp_end_st
= ST_OMP_END_MASKED
;
5856 omp_end_st
= ST_OMP_END_MASTER
;
5859 omp_end_st
= ST_OMP_END_SINGLE
;
5862 omp_end_st
= ST_OMP_END_TARGET
;
5864 case ST_OMP_TARGET_DATA
:
5865 omp_end_st
= ST_OMP_END_TARGET_DATA
;
5867 case ST_OMP_TARGET_PARALLEL
:
5868 omp_end_st
= ST_OMP_END_TARGET_PARALLEL
;
5870 case ST_OMP_TARGET_TEAMS
:
5871 omp_end_st
= ST_OMP_END_TARGET_TEAMS
;
5874 omp_end_st
= ST_OMP_END_TASK
;
5876 case ST_OMP_TASKGROUP
:
5877 omp_end_st
= ST_OMP_END_TASKGROUP
;
5880 omp_end_st
= ST_OMP_END_TEAMS
;
5882 case ST_OMP_TEAMS_DISTRIBUTE
:
5883 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
5885 case ST_OMP_DISTRIBUTE
:
5886 omp_end_st
= ST_OMP_END_DISTRIBUTE
;
5888 case ST_OMP_WORKSHARE
:
5889 omp_end_st
= ST_OMP_END_WORKSHARE
;
5891 case ST_OMP_PARALLEL_WORKSHARE
:
5892 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
5898 bool block_construct
= false;
5899 gfc_namespace
*my_ns
= NULL
;
5900 gfc_namespace
*my_parent
= NULL
;
5902 first_st
= st
= next_statement ();
5906 /* Adjust state to a strictly-structured block, now that we found that
5907 the body starts with a BLOCK construct. */
5908 s
.state
= COMP_OMP_STRICTLY_STRUCTURED_BLOCK
;
5910 block_construct
= true;
5911 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
5913 my_ns
= gfc_build_block_ns (gfc_current_ns
);
5914 new_st
.op
= EXEC_BLOCK
;
5915 new_st
.ext
.block
.ns
= my_ns
;
5916 new_st
.ext
.block
.assoc
= NULL
;
5917 accept_statement (ST_BLOCK
);
5919 push_state (&s2
, COMP_BLOCK
, my_ns
->proc_name
);
5920 gfc_current_ns
= my_ns
;
5921 my_parent
= my_ns
->parent
;
5922 if (omp_st
== ST_OMP_SECTIONS
5923 || omp_st
== ST_OMP_PARALLEL_SECTIONS
)
5925 np
= new_level (cp
);
5929 first_st
= next_statement ();
5930 st
= parse_spec (first_st
);
5933 if (omp_end_st
== ST_OMP_END_TARGET
)
5937 case ST_OMP_TEAMS_DISTRIBUTE
:
5938 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5939 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5940 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5941 case ST_OMP_TEAMS_LOOP
:
5943 gfc_state_data
*stk
= gfc_state_stack
->previous
;
5944 if (stk
->state
== COMP_OMP_STRICTLY_STRUCTURED_BLOCK
)
5945 stk
= stk
->previous
;
5946 stk
->tail
->ext
.omp_clauses
->target_first_st_is_teams
= true;
5955 if (workshare_stmts_only
)
5957 /* Inside of !$omp workshare, only
5960 where statements and constructs
5961 forall statements and constructs
5965 are allowed. For !$omp critical these
5966 restrictions apply recursively. */
5979 accept_statement (st
);
5982 case ST_WHERE_BLOCK
:
5983 parse_where_block ();
5986 case ST_FORALL_BLOCK
:
5987 parse_forall_block ();
5990 case ST_OMP_ALLOCATE_EXEC
:
5991 case ST_OMP_ALLOCATORS
:
5992 st
= parse_openmp_allocate_block (st
);
5996 case ST_OMP_PARALLEL
:
5997 case ST_OMP_PARALLEL_MASKED
:
5998 case ST_OMP_PARALLEL_MASTER
:
5999 case ST_OMP_PARALLEL_SECTIONS
:
6000 st
= parse_omp_structured_block (st
, false);
6003 case ST_OMP_PARALLEL_WORKSHARE
:
6004 case ST_OMP_CRITICAL
:
6005 st
= parse_omp_structured_block (st
, true);
6008 case ST_OMP_PARALLEL_DO
:
6009 case ST_OMP_PARALLEL_DO_SIMD
:
6010 st
= parse_omp_do (st
);
6014 st
= parse_omp_oacc_atomic (true);
6025 st
= next_statement ();
6029 st
= parse_executable (st
);
6032 else if (st
== ST_OMP_SECTION
6033 && (omp_st
== ST_OMP_SECTIONS
6034 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
6036 np
= new_level (np
);
6039 st
= next_statement ();
6041 else if (block_construct
&& st
== ST_END_BLOCK
)
6043 accept_statement (st
);
6044 gfc_current_ns
->code
= gfc_state_stack
->head
;
6045 gfc_current_ns
= my_parent
;
6046 pop_state (); /* Inner BLOCK */
6047 pop_state (); /* Outer COMP_OMP_STRICTLY_STRUCTURED_BLOCK */
6049 st
= next_statement ();
6050 if (st
== omp_end_st
)
6052 accept_statement (st
);
6053 st
= next_statement ();
6057 else if (st
!= omp_end_st
|| block_construct
)
6059 unexpected_statement (st
);
6060 st
= next_statement ();
6063 while (st
!= omp_end_st
);
6067 case EXEC_OMP_END_NOWAIT
:
6068 if (cp
->ext
.omp_clauses
->nowait
&& new_st
.ext
.omp_bool
)
6069 gfc_error_now ("Duplicated NOWAIT clause on %s and %s at %C",
6070 gfc_ascii_statement (omp_st
),
6071 gfc_ascii_statement (omp_end_st
));
6072 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
6074 case EXEC_OMP_END_CRITICAL
:
6075 if (((cp
->ext
.omp_clauses
->critical_name
== NULL
)
6076 ^ (new_st
.ext
.omp_name
== NULL
))
6077 || (new_st
.ext
.omp_name
!= NULL
6078 && strcmp (cp
->ext
.omp_clauses
->critical_name
,
6079 new_st
.ext
.omp_name
) != 0))
6080 gfc_error ("Name after !$omp critical and !$omp end critical does "
6082 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
6083 new_st
.ext
.omp_name
= NULL
;
6085 case EXEC_OMP_END_SINGLE
:
6086 if (cp
->ext
.omp_clauses
->nowait
&& new_st
.ext
.omp_clauses
->nowait
)
6087 gfc_error_now ("Duplicated NOWAIT clause on %s and %s at %C",
6088 gfc_ascii_statement (omp_st
),
6089 gfc_ascii_statement (omp_end_st
));
6090 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_clauses
->nowait
;
6091 if (cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
])
6093 gfc_omp_namelist
*nl
;
6094 for (nl
= cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
6095 nl
->next
; nl
= nl
->next
)
6097 nl
->next
= new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
6100 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
6101 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
6102 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
6103 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
6111 gfc_clear_new_st ();
6112 gfc_commit_symbols ();
6113 gfc_warning_check ();
6115 st
= next_statement ();
6120 /* Accept a series of executable statements. We return the first
6121 statement that doesn't fit to the caller. Any block statements are
6122 passed on to the correct handler, which usually passes the buck
6125 static gfc_statement
6126 parse_executable (gfc_statement st
)
6129 in_exec_part
= true;
6132 st
= next_statement ();
6136 close_flag
= check_do_closure ();
6141 case ST_END_PROGRAM
:
6144 case ST_END_FUNCTION
:
6149 case ST_END_SUBROUTINE
:
6154 case ST_SELECT_CASE
:
6155 gfc_error ("%s statement at %C cannot terminate a non-block "
6156 "DO loop", gfc_ascii_statement (st
));
6169 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
6170 "first executable statement");
6176 accept_statement (st
);
6177 if (close_flag
== 1)
6178 return ST_IMPLIED_ENDDO
;
6182 parse_block_construct ();
6193 case ST_SELECT_CASE
:
6194 parse_select_block ();
6197 case ST_SELECT_TYPE
:
6198 parse_select_type_block ();
6201 case ST_SELECT_RANK
:
6202 parse_select_rank_block ();
6207 if (check_do_closure () == 1)
6208 return ST_IMPLIED_ENDDO
;
6212 parse_critical_block ();
6215 case ST_WHERE_BLOCK
:
6216 parse_where_block ();
6219 case ST_FORALL_BLOCK
:
6220 parse_forall_block ();
6223 case ST_OACC_PARALLEL_LOOP
:
6224 case ST_OACC_KERNELS_LOOP
:
6225 case ST_OACC_SERIAL_LOOP
:
6227 st
= parse_oacc_loop (st
);
6228 if (st
== ST_IMPLIED_ENDDO
)
6232 case ST_OACC_PARALLEL
:
6233 case ST_OACC_KERNELS
:
6234 case ST_OACC_SERIAL
:
6236 case ST_OACC_HOST_DATA
:
6237 parse_oacc_structured_block (st
);
6240 case ST_OMP_ALLOCATE_EXEC
:
6241 case ST_OMP_ALLOCATORS
:
6242 st
= parse_openmp_allocate_block (st
);
6246 case ST_OMP_PARALLEL
:
6247 case ST_OMP_PARALLEL_MASKED
:
6248 case ST_OMP_PARALLEL_MASTER
:
6249 case ST_OMP_PARALLEL_SECTIONS
:
6250 case ST_OMP_ORDERED
:
6251 case ST_OMP_CRITICAL
:
6255 case ST_OMP_SECTIONS
:
6258 case ST_OMP_TARGET_DATA
:
6259 case ST_OMP_TARGET_PARALLEL
:
6260 case ST_OMP_TARGET_TEAMS
:
6263 case ST_OMP_TASKGROUP
:
6264 st
= parse_omp_structured_block (st
, false);
6267 case ST_OMP_WORKSHARE
:
6268 case ST_OMP_PARALLEL_WORKSHARE
:
6269 st
= parse_omp_structured_block (st
, true);
6272 case ST_OMP_DISTRIBUTE
:
6273 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
6274 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
6275 case ST_OMP_DISTRIBUTE_SIMD
:
6277 case ST_OMP_DO_SIMD
:
6279 case ST_OMP_PARALLEL_DO
:
6280 case ST_OMP_PARALLEL_DO_SIMD
:
6281 case ST_OMP_PARALLEL_LOOP
:
6282 case ST_OMP_PARALLEL_MASKED_TASKLOOP
:
6283 case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
6284 case ST_OMP_PARALLEL_MASTER_TASKLOOP
:
6285 case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
6286 case ST_OMP_MASKED_TASKLOOP
:
6287 case ST_OMP_MASKED_TASKLOOP_SIMD
:
6288 case ST_OMP_MASTER_TASKLOOP
:
6289 case ST_OMP_MASTER_TASKLOOP_SIMD
:
6291 case ST_OMP_TARGET_PARALLEL_DO
:
6292 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
6293 case ST_OMP_TARGET_PARALLEL_LOOP
:
6294 case ST_OMP_TARGET_SIMD
:
6295 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
6296 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
6297 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
6298 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
6299 case ST_OMP_TARGET_TEAMS_LOOP
:
6300 case ST_OMP_TASKLOOP
:
6301 case ST_OMP_TASKLOOP_SIMD
:
6302 case ST_OMP_TEAMS_DISTRIBUTE
:
6303 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
6304 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
6305 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
6306 case ST_OMP_TEAMS_LOOP
:
6307 st
= parse_omp_do (st
);
6308 if (st
== ST_IMPLIED_ENDDO
)
6312 case ST_OACC_ATOMIC
:
6313 st
= parse_omp_oacc_atomic (false);
6317 st
= parse_omp_oacc_atomic (true);
6324 if (directive_unroll
!= -1)
6325 gfc_error ("%<GCC unroll%> directive not at the start of a loop at %C");
6327 if (directive_ivdep
)
6328 gfc_error ("%<GCC ivdep%> directive not at the start of a loop at %C");
6330 if (directive_vector
)
6331 gfc_error ("%<GCC vector%> directive not at the start of a loop at %C");
6333 if (directive_novector
)
6334 gfc_error ("%<GCC novector%> "
6335 "directive not at the start of a loop at %C");
6337 st
= next_statement ();
6342 /* Fix the symbols for sibling functions. These are incorrectly added to
6343 the child namespace as the parser didn't know about this procedure. */
6346 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
6350 gfc_symbol
*old_sym
;
6352 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
6354 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
6356 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
6357 goto fixup_contained
;
6359 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
6360 && sym
->attr
.generic
&& sym
->attr
.function
)
6361 ||(sym
->attr
.flavor
== FL_DERIVED
6362 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
6363 goto fixup_contained
;
6365 old_sym
= st
->n
.sym
;
6366 if (old_sym
->ns
== ns
6367 && !old_sym
->attr
.contained
6369 /* By 14.6.1.3, host association should be excluded
6370 for the following. */
6371 && !(old_sym
->attr
.external
6372 || (old_sym
->ts
.type
!= BT_UNKNOWN
6373 && !old_sym
->attr
.implicit_type
)
6374 || old_sym
->attr
.flavor
== FL_PARAMETER
6375 || old_sym
->attr
.use_assoc
6376 || old_sym
->attr
.in_common
6377 || old_sym
->attr
.in_equivalence
6378 || old_sym
->attr
.data
6379 || old_sym
->attr
.dummy
6380 || old_sym
->attr
.result
6381 || old_sym
->attr
.dimension
6382 || old_sym
->attr
.allocatable
6383 || old_sym
->attr
.intrinsic
6384 || old_sym
->attr
.generic
6385 || old_sym
->attr
.flavor
== FL_NAMELIST
6386 || old_sym
->attr
.flavor
== FL_LABEL
6387 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
6389 /* Replace it with the symbol from the parent namespace. */
6393 gfc_release_symbol (old_sym
);
6397 /* Do the same for any contained procedures. */
6398 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
6403 parse_contained (int module
)
6405 gfc_namespace
*ns
, *parent_ns
, *tmp
;
6406 gfc_state_data s1
, s2
;
6411 int contains_statements
= 0;
6414 push_state (&s1
, COMP_CONTAINS
, NULL
);
6415 parent_ns
= gfc_current_ns
;
6419 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
6421 gfc_current_ns
->sibling
= parent_ns
->contained
;
6422 parent_ns
->contained
= gfc_current_ns
;
6425 /* Process the next available statement. We come here if we got an error
6426 and rejected the last statement. */
6427 old_loc
= gfc_current_locus
;
6428 st
= next_statement ();
6437 contains_statements
= 1;
6438 accept_statement (st
);
6441 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
6444 /* For internal procedures, create/update the symbol in the
6445 parent namespace. */
6449 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
6450 gfc_error ("Contained procedure %qs at %C is already "
6451 "ambiguous", gfc_new_block
->name
);
6454 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
6456 &gfc_new_block
->declared_at
))
6458 if (st
== ST_FUNCTION
)
6459 gfc_add_function (&sym
->attr
, sym
->name
,
6460 &gfc_new_block
->declared_at
);
6462 gfc_add_subroutine (&sym
->attr
, sym
->name
,
6463 &gfc_new_block
->declared_at
);
6467 gfc_commit_symbols ();
6470 sym
= gfc_new_block
;
6472 /* Mark this as a contained function, so it isn't replaced
6473 by other module functions. */
6474 sym
->attr
.contained
= 1;
6476 /* Set implicit_pure so that it can be reset if any of the
6477 tests for purity fail. This is used for some optimisation
6478 during translation. */
6479 if (!sym
->attr
.pure
)
6480 sym
->attr
.implicit_pure
= 1;
6482 parse_progunit (ST_NONE
);
6484 /* Fix up any sibling functions that refer to this one. */
6485 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
6486 /* Or refer to any of its alternate entry points. */
6487 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
6488 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
6490 gfc_current_ns
->code
= s2
.head
;
6491 gfc_current_ns
= parent_ns
;
6496 /* These statements are associated with the end of the host unit. */
6497 case ST_END_FUNCTION
:
6499 case ST_END_SUBMODULE
:
6500 case ST_END_PROGRAM
:
6501 case ST_END_SUBROUTINE
:
6502 accept_statement (st
);
6503 gfc_current_ns
->code
= s1
.head
;
6507 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
6508 gfc_ascii_statement (st
));
6509 reject_statement ();
6515 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
6516 && st
!= ST_END_MODULE
&& st
!= ST_END_SUBMODULE
6517 && st
!= ST_END_PROGRAM
);
6519 /* The first namespace in the list is guaranteed to not have
6520 anything (worthwhile) in it. */
6521 tmp
= gfc_current_ns
;
6522 gfc_current_ns
= parent_ns
;
6523 if (seen_error
&& tmp
->refs
> 1)
6524 gfc_free_namespace (tmp
);
6526 ns
= gfc_current_ns
->contained
;
6527 gfc_current_ns
->contained
= ns
->sibling
;
6528 gfc_free_namespace (ns
);
6531 if (!contains_statements
)
6532 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
6533 "FUNCTION or SUBROUTINE statement at %L", &old_loc
);
6537 /* The result variable in a MODULE PROCEDURE needs to be created and
6538 its characteristics copied from the interface since it is neither
6539 declared in the procedure declaration nor in the specification
6543 get_modproc_result (void)
6546 if (gfc_state_stack
->previous
6547 && gfc_state_stack
->previous
->state
== COMP_CONTAINS
6548 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
6550 proc
= gfc_current_ns
->proc_name
? gfc_current_ns
->proc_name
: NULL
;
6552 && proc
->attr
.function
6554 && proc
->tlink
->result
6555 && proc
->tlink
->result
!= proc
->tlink
)
6557 gfc_copy_dummy_sym (&proc
->result
, proc
->tlink
->result
, 1);
6558 gfc_set_sym_referenced (proc
->result
);
6559 proc
->result
->attr
.if_source
= IFSRC_DECL
;
6560 gfc_commit_symbol (proc
->result
);
6566 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
6569 parse_progunit (gfc_statement st
)
6574 gfc_adjust_builtins ();
6577 && gfc_new_block
->abr_modproc_decl
6578 && gfc_new_block
->attr
.function
)
6579 get_modproc_result ();
6581 st
= parse_spec (st
);
6588 /* This is not allowed within BLOCK! */
6589 if (gfc_current_state () != COMP_BLOCK
)
6594 accept_statement (st
);
6601 if (gfc_current_state () == COMP_FUNCTION
)
6602 gfc_check_function_type (gfc_current_ns
);
6607 st
= parse_executable (st
);
6615 /* This is not allowed within BLOCK! */
6616 if (gfc_current_state () != COMP_BLOCK
)
6621 accept_statement (st
);
6628 unexpected_statement (st
);
6629 reject_statement ();
6630 st
= next_statement ();
6636 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
6637 if (p
->state
== COMP_CONTAINS
)
6640 if (gfc_find_state (COMP_MODULE
) == true
6641 || gfc_find_state (COMP_SUBMODULE
) == true)
6646 gfc_error ("CONTAINS statement at %C is already in a contained "
6648 reject_statement ();
6649 st
= next_statement ();
6653 parse_contained (0);
6656 gfc_current_ns
->code
= gfc_state_stack
->head
;
6660 /* Come here to complain about a global symbol already in use as
6664 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
6669 where
= &gfc_current_locus
;
6679 case GSYM_SUBROUTINE
:
6680 name
= "SUBROUTINE";
6685 case GSYM_BLOCK_DATA
:
6686 name
= "BLOCK DATA";
6697 if (sym
->binding_label
)
6698 gfc_error ("Global binding name %qs at %L is already being used "
6699 "as a %s at %L", sym
->binding_label
, where
, name
,
6702 gfc_error ("Global name %qs at %L is already being used as "
6703 "a %s at %L", sym
->name
, where
, name
, &sym
->where
);
6707 if (sym
->binding_label
)
6708 gfc_error ("Global binding name %qs at %L is already being used "
6709 "at %L", sym
->binding_label
, where
, &sym
->where
);
6711 gfc_error ("Global name %qs at %L is already being used at %L",
6712 sym
->name
, where
, &sym
->where
);
6717 /* Parse a block data program unit. */
6720 parse_block_data (void)
6723 static locus blank_locus
;
6724 static int blank_block
=0;
6727 gfc_current_ns
->proc_name
= gfc_new_block
;
6728 gfc_current_ns
->is_block_data
= 1;
6730 if (gfc_new_block
== NULL
)
6733 gfc_error ("Blank BLOCK DATA at %C conflicts with "
6734 "prior BLOCK DATA at %L", &blank_locus
);
6738 blank_locus
= gfc_current_locus
;
6743 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6745 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
6746 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6749 s
->type
= GSYM_BLOCK_DATA
;
6750 s
->where
= gfc_new_block
->declared_at
;
6755 st
= parse_spec (ST_NONE
);
6757 while (st
!= ST_END_BLOCK_DATA
)
6759 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
6760 gfc_ascii_statement (st
));
6761 reject_statement ();
6762 st
= next_statement ();
6767 /* Following the association of the ancestor (sub)module symbols, they
6768 must be set host rather than use associated and all must be public.
6769 They are flagged up by 'used_in_submodule' so that they can be set
6770 DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
6771 linker chokes on multiple symbol definitions. */
6774 set_syms_host_assoc (gfc_symbol
*sym
)
6777 const char dot
[2] = ".";
6778 /* Symbols take the form module.submodule_ or module.name_. */
6779 char parent1
[2 * GFC_MAX_SYMBOL_LEN
+ 2];
6780 char parent2
[2 * GFC_MAX_SYMBOL_LEN
+ 2];
6785 if (sym
->attr
.module_procedure
)
6786 sym
->attr
.external
= 0;
6788 sym
->attr
.use_assoc
= 0;
6789 sym
->attr
.host_assoc
= 1;
6790 sym
->attr
.used_in_submodule
=1;
6792 if (sym
->attr
.flavor
== FL_DERIVED
)
6794 /* Derived types with PRIVATE components that are declared in
6795 modules other than the parent module must not be changed to be
6796 PUBLIC. The 'use-assoc' attribute must be reset so that the
6797 test in symbol.cc(gfc_find_component) works correctly. This is
6798 not necessary for PRIVATE symbols since they are not read from
6800 memset(parent1
, '\0', sizeof(parent1
));
6801 memset(parent2
, '\0', sizeof(parent2
));
6802 strcpy (parent1
, gfc_new_block
->name
);
6803 strcpy (parent2
, sym
->module
);
6804 if (strcmp (strtok (parent1
, dot
), strtok (parent2
, dot
)) == 0)
6806 for (c
= sym
->components
; c
; c
= c
->next
)
6807 c
->attr
.access
= ACCESS_PUBLIC
;
6811 sym
->attr
.use_assoc
= 1;
6812 sym
->attr
.host_assoc
= 0;
6817 /* Parse a module subprogram. */
6825 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6826 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
6827 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6830 s
->type
= GSYM_MODULE
;
6831 s
->where
= gfc_new_block
->declared_at
;
6835 /* Something is nulling the module_list after this point. This is good
6836 since it allows us to 'USE' the parent modules that the submodule
6837 inherits and to set (most) of the symbols as host associated. */
6838 if (gfc_current_state () == COMP_SUBMODULE
)
6841 gfc_traverse_ns (gfc_current_ns
, set_syms_host_assoc
);
6844 st
= parse_spec (ST_NONE
);
6853 parse_contained (1);
6857 case ST_END_SUBMODULE
:
6858 accept_statement (st
);
6862 gfc_error ("Unexpected %s statement in MODULE at %C",
6863 gfc_ascii_statement (st
));
6864 reject_statement ();
6865 st
= next_statement ();
6868 s
->ns
= gfc_current_ns
;
6872 /* Add a procedure name to the global symbol table. */
6875 add_global_procedure (bool sub
)
6879 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6880 name is a global identifier. */
6881 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
6883 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6886 || (s
->type
!= GSYM_UNKNOWN
6887 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
6889 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6890 /* Silence follow-up errors. */
6891 gfc_new_block
->binding_label
= NULL
;
6895 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6896 s
->sym_name
= gfc_new_block
->name
;
6897 s
->where
= gfc_new_block
->declared_at
;
6899 s
->ns
= gfc_current_ns
;
6903 /* Don't add the symbol multiple times. */
6904 if (gfc_new_block
->binding_label
6905 && (!gfc_notification_std (GFC_STD_F2008
)
6906 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
6908 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
, true);
6911 || (s
->type
!= GSYM_UNKNOWN
6912 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
6914 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6915 /* Silence follow-up errors. */
6916 gfc_new_block
->binding_label
= NULL
;
6920 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6921 s
->sym_name
= gfc_new_block
->name
;
6922 s
->binding_label
= gfc_new_block
->binding_label
;
6923 s
->where
= gfc_new_block
->declared_at
;
6925 s
->ns
= gfc_current_ns
;
6931 /* Add a program to the global symbol table. */
6934 add_global_program (void)
6938 if (gfc_new_block
== NULL
)
6940 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6942 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
6943 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6946 s
->type
= GSYM_PROGRAM
;
6947 s
->where
= gfc_new_block
->declared_at
;
6949 s
->ns
= gfc_current_ns
;
6954 /* Resolve all the program units. */
6956 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
6958 gfc_derived_types
= NULL
;
6959 gfc_current_ns
= gfc_global_ns_list
;
6960 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6962 if (gfc_current_ns
->proc_name
6963 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6964 continue; /* Already resolved. */
6966 if (gfc_current_ns
->proc_name
)
6967 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6968 gfc_resolve (gfc_current_ns
);
6969 gfc_current_ns
->derived_types
= gfc_derived_types
;
6970 gfc_derived_types
= NULL
;
6976 clean_up_modules (gfc_gsymbol
*&gsym
)
6981 clean_up_modules (gsym
->left
);
6982 clean_up_modules (gsym
->right
);
6984 if (gsym
->type
!= GSYM_MODULE
)
6989 gfc_current_ns
= gsym
->ns
;
6990 gfc_derived_types
= gfc_current_ns
->derived_types
;
6999 /* Translate all the program units. This could be in a different order
7000 to resolution if there are forward references in the file. */
7002 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
7006 gfc_current_ns
= gfc_global_ns_list
;
7007 gfc_get_errors (NULL
, &errors
);
7009 /* We first translate all modules to make sure that later parts
7010 of the program can use the decl. Then we translate the nonmodules. */
7012 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
7014 if (!gfc_current_ns
->proc_name
7015 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7018 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
7019 gfc_derived_types
= gfc_current_ns
->derived_types
;
7020 gfc_generate_module_code (gfc_current_ns
);
7021 gfc_current_ns
->translated
= 1;
7024 gfc_current_ns
= gfc_global_ns_list
;
7025 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
7027 if (gfc_current_ns
->proc_name
7028 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
7031 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
7032 gfc_derived_types
= gfc_current_ns
->derived_types
;
7033 gfc_generate_code (gfc_current_ns
);
7034 gfc_current_ns
->translated
= 1;
7037 /* Clean up all the namespaces after translation. */
7038 gfc_current_ns
= gfc_global_ns_list
;
7039 for (;gfc_current_ns
;)
7043 if (gfc_current_ns
->proc_name
7044 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
7046 gfc_current_ns
= gfc_current_ns
->sibling
;
7050 ns
= gfc_current_ns
->sibling
;
7051 gfc_derived_types
= gfc_current_ns
->derived_types
;
7053 gfc_current_ns
= ns
;
7056 clean_up_modules (gfc_gsym_root
);
7060 /* Top level parser. */
7063 gfc_parse_file (void)
7065 int seen_program
, errors_before
, errors
;
7066 gfc_state_data top
, s
;
7069 gfc_namespace
*next
;
7071 gfc_start_source_files ();
7073 top
.state
= COMP_NONE
;
7075 top
.previous
= NULL
;
7076 top
.head
= top
.tail
= NULL
;
7077 top
.do_variable
= NULL
;
7079 gfc_state_stack
= &top
;
7081 gfc_clear_new_st ();
7083 gfc_statement_label
= NULL
;
7085 if (setjmp (eof_buf
))
7086 return false; /* Come here on unexpected EOF */
7088 /* Prepare the global namespace that will contain the
7090 gfc_global_ns_list
= next
= NULL
;
7095 /* Exit early for empty files. */
7099 in_specification_block
= true;
7102 st
= next_statement ();
7111 goto duplicate_main
;
7113 prog_locus
= gfc_current_locus
;
7115 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
7116 main_program_symbol (gfc_current_ns
, gfc_new_block
->name
);
7117 accept_statement (st
);
7118 add_global_program ();
7119 parse_progunit (ST_NONE
);
7123 add_global_procedure (true);
7124 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
7125 accept_statement (st
);
7126 parse_progunit (ST_NONE
);
7130 add_global_procedure (false);
7131 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
7132 accept_statement (st
);
7133 parse_progunit (ST_NONE
);
7137 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
7138 accept_statement (st
);
7139 parse_block_data ();
7143 push_state (&s
, COMP_MODULE
, gfc_new_block
);
7144 accept_statement (st
);
7146 gfc_get_errors (NULL
, &errors_before
);
7151 push_state (&s
, COMP_SUBMODULE
, gfc_new_block
);
7152 accept_statement (st
);
7154 gfc_get_errors (NULL
, &errors_before
);
7158 /* Anything else starts a nameless main program block. */
7161 goto duplicate_main
;
7163 prog_locus
= gfc_current_locus
;
7165 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
7166 main_program_symbol (gfc_current_ns
, "MAIN__");
7167 parse_progunit (st
);
7171 /* Handle the non-program units. */
7172 gfc_current_ns
->code
= s
.head
;
7174 gfc_resolve (gfc_current_ns
);
7176 /* Fix the implicit_pure attribute for those procedures who should
7178 while (gfc_fix_implicit_pure (gfc_current_ns
))
7181 /* Dump the parse tree if requested. */
7182 if (flag_dump_fortran_original
)
7183 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
7185 gfc_get_errors (NULL
, &errors
);
7186 if (s
.state
== COMP_MODULE
|| s
.state
== COMP_SUBMODULE
)
7188 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
7189 gfc_current_ns
->derived_types
= gfc_derived_types
;
7190 gfc_derived_types
= NULL
;
7196 gfc_generate_code (gfc_current_ns
);
7204 /* The main program and non-contained procedures are put
7205 in the global namespace list, so that they can be processed
7206 later and all their interfaces resolved. */
7207 gfc_current_ns
->code
= s
.head
;
7210 for (; next
->sibling
; next
= next
->sibling
)
7212 next
->sibling
= gfc_current_ns
;
7215 gfc_global_ns_list
= gfc_current_ns
;
7217 next
= gfc_current_ns
;
7223 /* Do the resolution. */
7224 resolve_all_program_units (gfc_global_ns_list
);
7226 /* Go through all top-level namespaces and unset the implicit_pure
7227 attribute for any procedures that call something not pure or
7228 implicit_pure. Because the a procedure marked as not implicit_pure
7229 in one sweep may be called by another routine, we repeat this
7230 process until there are no more changes. */
7235 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
7236 gfc_current_ns
= gfc_current_ns
->sibling
)
7238 if (gfc_fix_implicit_pure (gfc_current_ns
))
7244 /* Fixup for external procedures and resolve 'omp requires'. */
7246 bool omp_target_seen
;
7248 omp_target_seen
= false;
7249 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
7250 gfc_current_ns
= gfc_current_ns
->sibling
)
7252 omp_requires
|= gfc_current_ns
->omp_requires
;
7253 omp_target_seen
|= gfc_current_ns
->omp_target_seen
;
7254 gfc_check_externals (gfc_current_ns
);
7256 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
7257 gfc_current_ns
= gfc_current_ns
->sibling
)
7258 gfc_check_omp_requires (gfc_current_ns
, omp_requires
);
7260 /* Populate omp_requires_mask (needed for resolving OpenMP
7261 metadirectives and declare variant). */
7262 switch (omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
7264 case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST
:
7266 = (enum omp_requires
) (omp_requires_mask
| OMP_MEMORY_ORDER_SEQ_CST
);
7268 case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL
:
7270 = (enum omp_requires
) (omp_requires_mask
| OMP_MEMORY_ORDER_ACQ_REL
);
7272 case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED
:
7274 = (enum omp_requires
) (omp_requires_mask
| OMP_MEMORY_ORDER_RELAXED
);
7278 if (omp_target_seen
)
7279 omp_requires_mask
= (enum omp_requires
) (omp_requires_mask
7280 | OMP_REQUIRES_TARGET_USED
);
7281 if (omp_requires
& OMP_REQ_REVERSE_OFFLOAD
)
7282 omp_requires_mask
= (enum omp_requires
) (omp_requires_mask
7283 | OMP_REQUIRES_REVERSE_OFFLOAD
);
7284 if (omp_requires
& OMP_REQ_UNIFIED_ADDRESS
)
7285 omp_requires_mask
= (enum omp_requires
) (omp_requires_mask
7286 | OMP_REQUIRES_UNIFIED_ADDRESS
);
7287 if (omp_requires
& OMP_REQ_UNIFIED_SHARED_MEMORY
)
7289 = (enum omp_requires
) (omp_requires_mask
7290 | OMP_REQUIRES_UNIFIED_SHARED_MEMORY
);
7291 if (omp_requires
& OMP_REQ_DYNAMIC_ALLOCATORS
)
7292 omp_requires_mask
= (enum omp_requires
) (omp_requires_mask
7293 | OMP_REQUIRES_DYNAMIC_ALLOCATORS
);
7294 /* Do the parse tree dump. */
7295 gfc_current_ns
= flag_dump_fortran_original
? gfc_global_ns_list
: NULL
;
7297 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
7298 if (!gfc_current_ns
->proc_name
7299 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7301 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
7302 fputs ("------------------------------------------\n\n", stdout
);
7305 /* Dump C prototypes. */
7306 if (flag_c_prototypes
|| flag_c_prototypes_external
)
7309 "#include <stddef.h>\n"
7310 "#ifdef __cplusplus\n"
7311 "#include <complex>\n"
7312 "#define __GFORTRAN_FLOAT_COMPLEX std::complex<float>\n"
7313 "#define __GFORTRAN_DOUBLE_COMPLEX std::complex<double>\n"
7314 "#define __GFORTRAN_LONG_DOUBLE_COMPLEX std::complex<long double>\n"
7317 "#define __GFORTRAN_FLOAT_COMPLEX float _Complex\n"
7318 "#define __GFORTRAN_DOUBLE_COMPLEX double _Complex\n"
7319 "#define __GFORTRAN_LONG_DOUBLE_COMPLEX long double _Complex\n"
7323 /* First dump BIND(C) prototypes. */
7324 if (flag_c_prototypes
)
7326 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
7327 gfc_current_ns
= gfc_current_ns
->sibling
)
7328 gfc_dump_c_prototypes (gfc_current_ns
, stdout
);
7331 /* Dump external prototypes. */
7332 if (flag_c_prototypes_external
)
7333 gfc_dump_external_c_prototypes (stdout
);
7335 if (flag_c_prototypes
|| flag_c_prototypes_external
)
7336 fprintf (stdout
, "\n#ifdef __cplusplus\n}\n#endif\n");
7338 /* Do the translation. */
7339 translate_all_program_units (gfc_global_ns_list
);
7341 /* Dump the global symbol ist. We only do this here because part
7342 of it is generated after mangling the identifiers in
7345 if (flag_dump_fortran_global
)
7346 gfc_dump_global_symbols (stdout
);
7348 gfc_end_source_files ();
7352 /* If we see a duplicate main program, shut down. If the second
7353 instance is an implied main program, i.e. data decls or executable
7354 statements, we're in for lots of errors. */
7355 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
7356 reject_statement ();
7361 /* Return true if this state data represents an OpenACC region. */
7363 is_oacc (gfc_state_data
*sd
)
7365 switch (sd
->construct
->op
)
7367 case EXEC_OACC_PARALLEL_LOOP
:
7368 case EXEC_OACC_PARALLEL
:
7369 case EXEC_OACC_KERNELS_LOOP
:
7370 case EXEC_OACC_KERNELS
:
7371 case EXEC_OACC_SERIAL_LOOP
:
7372 case EXEC_OACC_SERIAL
:
7373 case EXEC_OACC_DATA
:
7374 case EXEC_OACC_HOST_DATA
:
7375 case EXEC_OACC_LOOP
:
7376 case EXEC_OACC_UPDATE
:
7377 case EXEC_OACC_WAIT
:
7378 case EXEC_OACC_CACHE
:
7379 case EXEC_OACC_ENTER_DATA
:
7380 case EXEC_OACC_EXIT_DATA
:
7381 case EXEC_OACC_ATOMIC
:
7382 case EXEC_OACC_ROUTINE
: