2 Copyright (C) 2000-2024 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;
1367 case ST_OMP_ALLOCATE_EXEC
:
1368 case ST_OMP_ALLOCATORS
:
1370 case ST_OMP_TEAMS_DISTRIBUTE
:
1371 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
1372 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1373 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1374 case ST_OMP_TEAMS_LOOP
:
1375 for (gfc_state_data
*stk
= gfc_state_stack
->previous
; stk
;
1376 stk
= stk
->previous
)
1377 if (stk
&& stk
->tail
)
1378 switch (stk
->tail
->op
)
1380 case EXEC_OMP_TARGET
:
1381 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE
:
1382 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
1383 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
1384 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
1385 case EXEC_OMP_TARGET_TEAMS_LOOP
:
1386 case EXEC_OMP_TARGET_PARALLEL
:
1387 case EXEC_OMP_TARGET_PARALLEL_DO
:
1388 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD
:
1389 case EXEC_OMP_TARGET_PARALLEL_LOOP
:
1390 case EXEC_OMP_TARGET_SIMD
:
1391 if (ret
== ST_OMP_ALLOCATE_EXEC
|| ret
== ST_OMP_ALLOCATORS
)
1392 new_st
.ext
.omp_clauses
->contained_in_target_construct
= 1;
1394 stk
->tail
->ext
.omp_clauses
->contains_teams_construct
= 1;
1401 if (new_st
.ext
.omp_clauses
->at
!= OMP_AT_EXECUTION
)
1409 reject_statement ();
1411 gfc_buffer_error (false);
1412 gfc_current_locus
= old_locus
;
1413 return ST_GET_FCN_CHARACTERISTICS
;
1416 static gfc_statement
1417 decode_gcc_attribute (void)
1421 gfc_enforce_clean_symbol_state ();
1423 gfc_clear_error (); /* Clear any pending errors. */
1424 gfc_clear_warning (); /* Clear any pending warnings. */
1425 old_locus
= gfc_current_locus
;
1427 match ("attributes", gfc_match_gcc_attributes
, ST_ATTR_DECL
);
1428 match ("unroll", gfc_match_gcc_unroll
, ST_NONE
);
1429 match ("builtin", gfc_match_gcc_builtin
, ST_NONE
);
1430 match ("ivdep", gfc_match_gcc_ivdep
, ST_NONE
);
1431 match ("vector", gfc_match_gcc_vector
, ST_NONE
);
1432 match ("novector", gfc_match_gcc_novector
, ST_NONE
);
1434 /* All else has failed, so give up. See if any of the matchers has
1435 stored an error message of some sort. */
1437 if (!gfc_error_check ())
1440 gfc_error_now ("Unclassifiable GCC directive at %C");
1442 gfc_warning_now (0, "Unclassifiable GCC directive at %C, ignored");
1445 reject_statement ();
1447 gfc_error_recovery ();
1454 /* Assert next length characters to be equal to token in free form. */
1457 verify_token_free (const char* token
, int length
, bool last_was_use_stmt
)
1462 c
= gfc_next_ascii_char ();
1463 for (i
= 0; i
< length
; i
++, c
= gfc_next_ascii_char ())
1464 gcc_assert (c
== token
[i
]);
1466 gcc_assert (gfc_is_whitespace(c
));
1467 gfc_gobble_whitespace ();
1468 if (last_was_use_stmt
)
1472 /* Get the next statement in free form source. */
1474 static gfc_statement
1481 at_bol
= gfc_at_bol ();
1482 gfc_gobble_whitespace ();
1484 c
= gfc_peek_ascii_char ();
1490 /* Found a statement label? */
1491 m
= gfc_match_st_label (&gfc_statement_label
);
1493 d
= gfc_peek_ascii_char ();
1494 if (m
!= MATCH_YES
|| !gfc_is_whitespace (d
))
1496 gfc_match_small_literal_int (&i
, &cnt
);
1499 gfc_error_now ("Too many digits in statement label at %C");
1502 gfc_error_now ("Zero is not a valid statement label at %C");
1505 c
= gfc_next_ascii_char ();
1508 if (!gfc_is_whitespace (c
))
1509 gfc_error_now ("Non-numeric character in statement label at %C");
1515 label_locus
= gfc_current_locus
;
1517 gfc_gobble_whitespace ();
1519 if (at_bol
&& gfc_peek_ascii_char () == ';')
1521 gfc_error_now ("Semicolon at %C needs to be preceded by "
1523 gfc_next_ascii_char (); /* Eat up the semicolon. */
1527 if (gfc_match_eos () == MATCH_YES
)
1528 gfc_error_now ("Statement label without statement at %L",
1534 /* Comments have already been skipped by the time we get here,
1535 except for GCC attributes and OpenMP/OpenACC directives. */
1537 gfc_next_ascii_char (); /* Eat up the exclamation sign. */
1538 c
= gfc_peek_ascii_char ();
1544 c
= gfc_next_ascii_char ();
1545 for (i
= 0; i
< 4; i
++, c
= gfc_next_ascii_char ())
1546 gcc_assert (c
== "gcc$"[i
]);
1548 gfc_gobble_whitespace ();
1549 return decode_gcc_attribute ();
1554 /* Since both OpenMP and OpenACC directives starts with
1555 !$ character sequence, we must check all flags combinations */
1556 if ((flag_openmp
|| flag_openmp_simd
)
1559 verify_token_free ("$omp", 4, last_was_use_stmt
);
1560 return decode_omp_directive ();
1562 else if ((flag_openmp
|| flag_openmp_simd
)
1565 gfc_next_ascii_char (); /* Eat up dollar character */
1566 c
= gfc_peek_ascii_char ();
1570 verify_token_free ("omp", 3, last_was_use_stmt
);
1571 return decode_omp_directive ();
1575 verify_token_free ("acc", 3, last_was_use_stmt
);
1576 return decode_oacc_directive ();
1579 else if (flag_openacc
)
1581 verify_token_free ("$acc", 4, last_was_use_stmt
);
1582 return decode_oacc_directive ();
1588 if (at_bol
&& c
== ';')
1590 if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1591 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1593 gfc_next_ascii_char (); /* Eat up the semicolon. */
1597 return decode_statement ();
1600 /* Assert next length characters to be equal to token in fixed form. */
1603 verify_token_fixed (const char *token
, int length
, bool last_was_use_stmt
)
1606 char c
= gfc_next_char_literal (NONSTRING
);
1608 for (i
= 0; i
< length
; i
++, c
= gfc_next_char_literal (NONSTRING
))
1609 gcc_assert ((char) gfc_wide_tolower (c
) == token
[i
]);
1611 if (c
!= ' ' && c
!= '0')
1613 gfc_buffer_error (false);
1614 gfc_error ("Bad continuation line at %C");
1617 if (last_was_use_stmt
)
1623 /* Get the next statement in fixed-form source. */
1625 static gfc_statement
1628 int label
, digit_flag
, i
;
1633 return decode_statement ();
1635 /* Skip past the current label field, parsing a statement label if
1636 one is there. This is a weird number parser, since the number is
1637 contained within five columns and can have any kind of embedded
1638 spaces. We also check for characters that make the rest of the
1644 for (i
= 0; i
< 5; i
++)
1646 c
= gfc_next_char_literal (NONSTRING
);
1663 label
= label
* 10 + ((unsigned char) c
- '0');
1664 label_locus
= gfc_current_locus
;
1668 /* Comments have already been skipped by the time we get
1669 here, except for GCC attributes and OpenMP directives. */
1672 c
= gfc_next_char_literal (NONSTRING
);
1674 if (TOLOWER (c
) == 'g')
1676 for (i
= 0; i
< 4; i
++, c
= gfc_next_char_literal (NONSTRING
))
1677 gcc_assert (TOLOWER (c
) == "gcc$"[i
]);
1679 return decode_gcc_attribute ();
1683 if ((flag_openmp
|| flag_openmp_simd
)
1686 if (!verify_token_fixed ("omp", 3, last_was_use_stmt
))
1688 return decode_omp_directive ();
1690 else if ((flag_openmp
|| flag_openmp_simd
)
1693 c
= gfc_next_char_literal(NONSTRING
);
1694 if (c
== 'o' || c
== 'O')
1696 if (!verify_token_fixed ("mp", 2, last_was_use_stmt
))
1698 return decode_omp_directive ();
1700 else if (c
== 'a' || c
== 'A')
1702 if (!verify_token_fixed ("cc", 2, last_was_use_stmt
))
1704 return decode_oacc_directive ();
1707 else if (flag_openacc
)
1709 if (!verify_token_fixed ("acc", 3, last_was_use_stmt
))
1711 return decode_oacc_directive ();
1716 /* Comments have already been skipped by the time we get
1717 here so don't bother checking for them. */
1720 gfc_buffer_error (false);
1721 gfc_error ("Non-numeric character in statement label at %C");
1729 gfc_warning_now (0, "Zero is not a valid statement label at %C");
1732 /* We've found a valid statement label. */
1733 gfc_statement_label
= gfc_get_st_label (label
);
1737 /* Since this line starts a statement, it cannot be a continuation
1738 of a previous statement. If we see something here besides a
1739 space or zero, it must be a bad continuation line. */
1741 c
= gfc_next_char_literal (NONSTRING
);
1745 if (c
!= ' ' && c
!= '0')
1747 gfc_buffer_error (false);
1748 gfc_error ("Bad continuation line at %C");
1752 /* Now that we've taken care of the statement label columns, we have
1753 to make sure that the first nonblank character is not a '!'. If
1754 it is, the rest of the line is a comment. */
1758 loc
= gfc_current_locus
;
1759 c
= gfc_next_char_literal (NONSTRING
);
1761 while (gfc_is_whitespace (c
));
1765 gfc_current_locus
= loc
;
1770 gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1771 else if (!(gfc_option
.allow_std
& GFC_STD_F2008
))
1772 gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1777 if (gfc_match_eos () == MATCH_YES
)
1780 /* At this point, we've got a nonblank statement to parse. */
1781 return decode_statement ();
1785 gfc_error_now ("Statement label without statement at %L", &label_locus
);
1787 gfc_current_locus
.lb
->truncated
= 0;
1788 gfc_advance_line ();
1793 /* Return the next non-ST_NONE statement to the caller. We also worry
1794 about including files and the ends of include files at this stage. */
1796 static gfc_statement
1797 next_statement (void)
1802 gfc_enforce_clean_symbol_state ();
1804 gfc_new_block
= NULL
;
1806 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1807 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
1810 gfc_statement_label
= NULL
;
1811 gfc_buffer_error (true);
1814 gfc_advance_line ();
1816 gfc_skip_comments ();
1824 if (gfc_define_undef_line ())
1827 old_locus
= gfc_current_locus
;
1829 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1835 gfc_buffer_error (false);
1837 if (st
== ST_GET_FCN_CHARACTERISTICS
)
1839 if (gfc_statement_label
!= NULL
)
1841 gfc_free_st_label (gfc_statement_label
);
1842 gfc_statement_label
= NULL
;
1844 gfc_current_locus
= old_locus
;
1848 check_statement_label (st
);
1854 /****************************** Parser ***********************************/
1856 /* The parser subroutines are of type 'try' that fail if the file ends
1859 /* Macros that expand to case-labels for various classes of
1860 statements. Start with executable statements that directly do
1863 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1864 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1865 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1866 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1867 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1868 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1869 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1870 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1871 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1872 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: case ST_OMP_DEPOBJ: \
1873 case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
1874 case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: case ST_OMP_ERROR: \
1875 case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \
1876 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1877 case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
1878 case ST_END_TEAM: case ST_SYNC_TEAM: \
1879 case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
1880 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1881 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1883 /* Statements that mark other executable statements. */
1885 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1886 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1887 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1888 case ST_SELECT_RANK: case ST_OMP_PARALLEL: case ST_OMP_PARALLEL_MASKED: \
1889 case ST_OMP_PARALLEL_MASKED_TASKLOOP: \
1890 case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: case ST_OMP_PARALLEL_MASTER: \
1891 case ST_OMP_PARALLEL_MASTER_TASKLOOP: \
1892 case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: \
1893 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1894 case ST_OMP_CRITICAL: case ST_OMP_MASKED: case ST_OMP_MASKED_TASKLOOP: \
1895 case ST_OMP_MASKED_TASKLOOP_SIMD: \
1896 case ST_OMP_MASTER: case ST_OMP_MASTER_TASKLOOP: \
1897 case ST_OMP_MASTER_TASKLOOP_SIMD: case ST_OMP_SCOPE: case ST_OMP_SINGLE: \
1898 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1899 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1900 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1901 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1902 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1903 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1904 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1905 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1906 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1907 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1908 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1909 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1910 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1911 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1912 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \
1913 case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \
1914 case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
1915 case ST_OMP_LOOP: case ST_OMP_PARALLEL_LOOP: case ST_OMP_TEAMS_LOOP: \
1916 case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_TEAMS_LOOP: \
1917 case ST_OMP_ALLOCATE_EXEC: case ST_OMP_ALLOCATORS: case ST_OMP_ASSUME: \
1919 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1920 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
1921 case ST_OACC_KERNELS_LOOP: case ST_OACC_SERIAL_LOOP: case ST_OACC_SERIAL: \
1924 /* Declaration statements */
1926 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1927 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1928 case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE
1930 /* OpenMP and OpenACC declaration statements, which may appear anywhere in
1931 the specification part. */
1933 #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
1934 case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \
1935 case ST_OMP_DECLARE_VARIANT: case ST_OMP_ALLOCATE: case ST_OMP_ASSUMES: \
1936 case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
1938 /* Block end statements. Errors associated with interchanging these
1939 are detected in gfc_match_end(). */
1941 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1942 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1943 case ST_END_BLOCK: case ST_END_ASSOCIATE
1946 /* Push a new state onto the stack. */
1949 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1951 p
->state
= new_state
;
1952 p
->previous
= gfc_state_stack
;
1954 p
->head
= p
->tail
= NULL
;
1955 p
->do_variable
= NULL
;
1956 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1957 p
->ext
.oacc_declare_clauses
= NULL
;
1959 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1960 construct statement was accepted right before pushing the state. Thus,
1961 the construct's gfc_code is available as tail of the parent state. */
1962 gcc_assert (gfc_state_stack
);
1963 p
->construct
= gfc_state_stack
->tail
;
1965 gfc_state_stack
= p
;
1969 /* Pop the current state. */
1973 gfc_state_stack
= gfc_state_stack
->previous
;
1977 /* Try to find the given state in the state stack. */
1980 gfc_find_state (gfc_compile_state state
)
1984 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1985 if (p
->state
== state
)
1988 return (p
== NULL
) ? false : true;
1992 /* Starts a new level in the statement list. */
1995 new_level (gfc_code
*q
)
1999 p
= q
->block
= gfc_get_code (EXEC_NOP
);
2001 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
2007 /* Add the current new_st code structure and adds it to the current
2008 program unit. As a side-effect, it zeroes the new_st. */
2011 add_statement (void)
2015 p
= XCNEW (gfc_code
);
2018 p
->loc
= gfc_current_locus
;
2020 if (gfc_state_stack
->head
== NULL
)
2021 gfc_state_stack
->head
= p
;
2023 gfc_state_stack
->tail
->next
= p
;
2025 while (p
->next
!= NULL
)
2028 gfc_state_stack
->tail
= p
;
2030 gfc_clear_new_st ();
2036 /* Frees everything associated with the current statement. */
2039 undo_new_statement (void)
2041 gfc_free_statements (new_st
.block
);
2042 gfc_free_statements (new_st
.next
);
2043 gfc_free_statement (&new_st
);
2044 gfc_clear_new_st ();
2048 /* If the current statement has a statement label, make sure that it
2049 is allowed to, or should have one. */
2052 check_statement_label (gfc_statement st
)
2056 if (gfc_statement_label
== NULL
)
2058 if (st
== ST_FORMAT
)
2059 gfc_error ("FORMAT statement at %L does not have a statement label",
2066 case ST_END_PROGRAM
:
2067 case ST_END_FUNCTION
:
2068 case ST_END_SUBROUTINE
:
2072 case ST_END_CRITICAL
:
2074 case ST_END_ASSOCIATE
:
2077 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
2078 type
= ST_LABEL_DO_TARGET
;
2080 type
= ST_LABEL_TARGET
;
2084 type
= ST_LABEL_FORMAT
;
2087 /* Statement labels are not restricted from appearing on a
2088 particular line. However, there are plenty of situations
2089 where the resulting label can't be referenced. */
2092 type
= ST_LABEL_BAD_TARGET
;
2096 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
2098 new_st
.here
= gfc_statement_label
;
2102 /* Figures out what the enclosing program unit is. This will be a
2103 function, subroutine, program, block data or module. */
2106 gfc_enclosing_unit (gfc_compile_state
* result
)
2110 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
2111 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
2112 || p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
2113 || p
->state
== COMP_BLOCK_DATA
|| p
->state
== COMP_PROGRAM
)
2122 *result
= COMP_PROGRAM
;
2127 /* Translate a statement enum to a string. If strip_sentinel is true,
2128 the !$OMP/!$ACC sentinel is excluded. */
2131 gfc_ascii_statement (gfc_statement st
, bool strip_sentinel
)
2137 case ST_ARITHMETIC_IF
:
2138 p
= _("arithmetic IF");
2147 p
= _("attribute declaration");
2183 p
= _("data declaration");
2197 case ST_STRUCTURE_DECL
:
2200 case ST_DERIVED_DECL
:
2201 p
= _("derived type declaration");
2224 case ST_CHANGE_TEAM
:
2236 case ST_END_ASSOCIATE
:
2237 p
= "END ASSOCIATE";
2242 case ST_END_BLOCK_DATA
:
2243 p
= "END BLOCK DATA";
2245 case ST_END_CRITICAL
:
2257 case ST_END_FUNCTION
:
2263 case ST_END_INTERFACE
:
2264 p
= "END INTERFACE";
2269 case ST_END_SUBMODULE
:
2270 p
= "END SUBMODULE";
2272 case ST_END_PROGRAM
:
2278 case ST_END_SUBROUTINE
:
2279 p
= "END SUBROUTINE";
2284 case ST_END_STRUCTURE
:
2285 p
= "END STRUCTURE";
2299 case ST_EQUIVALENCE
:
2311 case ST_FORALL_BLOCK
: /* Fall through */
2333 case ST_IMPLICIT_NONE
:
2334 p
= "IMPLICIT NONE";
2336 case ST_IMPLIED_ENDDO
:
2337 p
= _("implied END DO");
2369 case ST_MODULE_PROC
:
2370 p
= "MODULE PROCEDURE";
2402 case ST_SYNC_IMAGES
:
2405 case ST_SYNC_MEMORY
:
2420 case ST_WHERE_BLOCK
: /* Fall through */
2431 p
= _("assignment");
2433 case ST_POINTER_ASSIGNMENT
:
2434 p
= _("pointer assignment");
2436 case ST_SELECT_CASE
:
2439 case ST_SELECT_TYPE
:
2442 case ST_SELECT_RANK
:
2460 case ST_STATEMENT_FUNCTION
:
2461 p
= "STATEMENT FUNCTION";
2463 case ST_LABEL_ASSIGNMENT
:
2464 p
= "LABEL ASSIGNMENT";
2467 p
= "ENUM DEFINITION";
2470 p
= "ENUMERATOR DEFINITION";
2475 case ST_OACC_PARALLEL_LOOP
:
2476 p
= "!$ACC PARALLEL LOOP";
2478 case ST_OACC_END_PARALLEL_LOOP
:
2479 p
= "!$ACC END PARALLEL LOOP";
2481 case ST_OACC_PARALLEL
:
2482 p
= "!$ACC PARALLEL";
2484 case ST_OACC_END_PARALLEL
:
2485 p
= "!$ACC END PARALLEL";
2487 case ST_OACC_KERNELS
:
2488 p
= "!$ACC KERNELS";
2490 case ST_OACC_END_KERNELS
:
2491 p
= "!$ACC END KERNELS";
2493 case ST_OACC_KERNELS_LOOP
:
2494 p
= "!$ACC KERNELS LOOP";
2496 case ST_OACC_END_KERNELS_LOOP
:
2497 p
= "!$ACC END KERNELS LOOP";
2499 case ST_OACC_SERIAL_LOOP
:
2500 p
= "!$ACC SERIAL LOOP";
2502 case ST_OACC_END_SERIAL_LOOP
:
2503 p
= "!$ACC END SERIAL LOOP";
2505 case ST_OACC_SERIAL
:
2508 case ST_OACC_END_SERIAL
:
2509 p
= "!$ACC END SERIAL";
2514 case ST_OACC_END_DATA
:
2515 p
= "!$ACC END DATA";
2517 case ST_OACC_HOST_DATA
:
2518 p
= "!$ACC HOST_DATA";
2520 case ST_OACC_END_HOST_DATA
:
2521 p
= "!$ACC END HOST_DATA";
2526 case ST_OACC_END_LOOP
:
2527 p
= "!$ACC END LOOP";
2529 case ST_OACC_DECLARE
:
2530 p
= "!$ACC DECLARE";
2532 case ST_OACC_UPDATE
:
2541 case ST_OACC_ENTER_DATA
:
2542 p
= "!$ACC ENTER DATA";
2544 case ST_OACC_EXIT_DATA
:
2545 p
= "!$ACC EXIT DATA";
2547 case ST_OACC_ROUTINE
:
2548 p
= "!$ACC ROUTINE";
2550 case ST_OACC_ATOMIC
:
2553 case ST_OACC_END_ATOMIC
:
2554 p
= "!$ACC END ATOMIC";
2556 case ST_OMP_ALLOCATE
:
2557 case ST_OMP_ALLOCATE_EXEC
:
2558 p
= "!$OMP ALLOCATE";
2560 case ST_OMP_ALLOCATORS
:
2561 p
= "!$OMP ALLOCATORS";
2566 case ST_OMP_ASSUMES
:
2567 p
= "!$OMP ASSUMES";
2572 case ST_OMP_BARRIER
:
2573 p
= "!$OMP BARRIER";
2578 case ST_OMP_CANCELLATION_POINT
:
2579 p
= "!$OMP CANCELLATION POINT";
2581 case ST_OMP_CRITICAL
:
2582 p
= "!$OMP CRITICAL";
2584 case ST_OMP_DECLARE_REDUCTION
:
2585 p
= "!$OMP DECLARE REDUCTION";
2587 case ST_OMP_DECLARE_SIMD
:
2588 p
= "!$OMP DECLARE SIMD";
2590 case ST_OMP_DECLARE_TARGET
:
2591 p
= "!$OMP DECLARE TARGET";
2593 case ST_OMP_DECLARE_VARIANT
:
2594 p
= "!$OMP DECLARE VARIANT";
2599 case ST_OMP_DISTRIBUTE
:
2600 p
= "!$OMP DISTRIBUTE";
2602 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
2603 p
= "!$OMP DISTRIBUTE PARALLEL DO";
2605 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2606 p
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
2608 case ST_OMP_DISTRIBUTE_SIMD
:
2609 p
= "!$OMP DISTRIBUTE SIMD";
2614 case ST_OMP_DO_SIMD
:
2615 p
= "!$OMP DO SIMD";
2617 case ST_OMP_END_ALLOCATORS
:
2618 p
= "!$OMP END ALLOCATORS";
2620 case ST_OMP_END_ASSUME
:
2621 p
= "!$OMP END ASSUME";
2623 case ST_OMP_END_ATOMIC
:
2624 p
= "!$OMP END ATOMIC";
2626 case ST_OMP_END_CRITICAL
:
2627 p
= "!$OMP END CRITICAL";
2629 case ST_OMP_END_DISTRIBUTE
:
2630 p
= "!$OMP END DISTRIBUTE";
2632 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO
:
2633 p
= "!$OMP END DISTRIBUTE PARALLEL DO";
2635 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
:
2636 p
= "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
2638 case ST_OMP_END_DISTRIBUTE_SIMD
:
2639 p
= "!$OMP END DISTRIBUTE SIMD";
2644 case ST_OMP_END_DO_SIMD
:
2645 p
= "!$OMP END DO SIMD";
2647 case ST_OMP_END_SCOPE
:
2648 p
= "!$OMP END SCOPE";
2650 case ST_OMP_END_SIMD
:
2651 p
= "!$OMP END SIMD";
2653 case ST_OMP_END_LOOP
:
2654 p
= "!$OMP END LOOP";
2656 case ST_OMP_END_MASKED
:
2657 p
= "!$OMP END MASKED";
2659 case ST_OMP_END_MASKED_TASKLOOP
:
2660 p
= "!$OMP END MASKED TASKLOOP";
2662 case ST_OMP_END_MASKED_TASKLOOP_SIMD
:
2663 p
= "!$OMP END MASKED TASKLOOP SIMD";
2665 case ST_OMP_END_MASTER
:
2666 p
= "!$OMP END MASTER";
2668 case ST_OMP_END_MASTER_TASKLOOP
:
2669 p
= "!$OMP END MASTER TASKLOOP";
2671 case ST_OMP_END_MASTER_TASKLOOP_SIMD
:
2672 p
= "!$OMP END MASTER TASKLOOP SIMD";
2674 case ST_OMP_END_ORDERED
:
2675 p
= "!$OMP END ORDERED";
2677 case ST_OMP_END_PARALLEL
:
2678 p
= "!$OMP END PARALLEL";
2680 case ST_OMP_END_PARALLEL_DO
:
2681 p
= "!$OMP END PARALLEL DO";
2683 case ST_OMP_END_PARALLEL_DO_SIMD
:
2684 p
= "!$OMP END PARALLEL DO SIMD";
2686 case ST_OMP_END_PARALLEL_LOOP
:
2687 p
= "!$OMP END PARALLEL LOOP";
2689 case ST_OMP_END_PARALLEL_MASKED
:
2690 p
= "!$OMP END PARALLEL MASKED";
2692 case ST_OMP_END_PARALLEL_MASKED_TASKLOOP
:
2693 p
= "!$OMP END PARALLEL MASKED TASKLOOP";
2695 case ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD
:
2696 p
= "!$OMP END PARALLEL MASKED TASKLOOP SIMD";
2698 case ST_OMP_END_PARALLEL_MASTER
:
2699 p
= "!$OMP END PARALLEL MASTER";
2701 case ST_OMP_END_PARALLEL_MASTER_TASKLOOP
:
2702 p
= "!$OMP END PARALLEL MASTER TASKLOOP";
2704 case ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD
:
2705 p
= "!$OMP END PARALLEL MASTER TASKLOOP SIMD";
2707 case ST_OMP_END_PARALLEL_SECTIONS
:
2708 p
= "!$OMP END PARALLEL SECTIONS";
2710 case ST_OMP_END_PARALLEL_WORKSHARE
:
2711 p
= "!$OMP END PARALLEL WORKSHARE";
2713 case ST_OMP_END_SECTIONS
:
2714 p
= "!$OMP END SECTIONS";
2716 case ST_OMP_END_SINGLE
:
2717 p
= "!$OMP END SINGLE";
2719 case ST_OMP_END_TASK
:
2720 p
= "!$OMP END TASK";
2722 case ST_OMP_END_TARGET
:
2723 p
= "!$OMP END TARGET";
2725 case ST_OMP_END_TARGET_DATA
:
2726 p
= "!$OMP END TARGET DATA";
2728 case ST_OMP_END_TARGET_PARALLEL
:
2729 p
= "!$OMP END TARGET PARALLEL";
2731 case ST_OMP_END_TARGET_PARALLEL_DO
:
2732 p
= "!$OMP END TARGET PARALLEL DO";
2734 case ST_OMP_END_TARGET_PARALLEL_DO_SIMD
:
2735 p
= "!$OMP END TARGET PARALLEL DO SIMD";
2737 case ST_OMP_END_TARGET_PARALLEL_LOOP
:
2738 p
= "!$OMP END TARGET PARALLEL LOOP";
2740 case ST_OMP_END_TARGET_SIMD
:
2741 p
= "!$OMP END TARGET SIMD";
2743 case ST_OMP_END_TARGET_TEAMS
:
2744 p
= "!$OMP END TARGET TEAMS";
2746 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
:
2747 p
= "!$OMP END TARGET TEAMS DISTRIBUTE";
2749 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2750 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2752 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2753 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2755 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2756 p
= "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2758 case ST_OMP_END_TARGET_TEAMS_LOOP
:
2759 p
= "!$OMP END TARGET TEAMS LOOP";
2761 case ST_OMP_END_TASKGROUP
:
2762 p
= "!$OMP END TASKGROUP";
2764 case ST_OMP_END_TASKLOOP
:
2765 p
= "!$OMP END TASKLOOP";
2767 case ST_OMP_END_TASKLOOP_SIMD
:
2768 p
= "!$OMP END TASKLOOP SIMD";
2770 case ST_OMP_END_TEAMS
:
2771 p
= "!$OMP END TEAMS";
2773 case ST_OMP_END_TEAMS_DISTRIBUTE
:
2774 p
= "!$OMP END TEAMS DISTRIBUTE";
2776 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2777 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2779 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2780 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2782 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
:
2783 p
= "!$OMP END TEAMS DISTRIBUTE SIMD";
2785 case ST_OMP_END_TEAMS_LOOP
:
2786 p
= "!$OMP END TEAMS LOOP";
2788 case ST_OMP_END_WORKSHARE
:
2789 p
= "!$OMP END WORKSHARE";
2803 case ST_OMP_MASKED_TASKLOOP
:
2804 p
= "!$OMP MASKED TASKLOOP";
2806 case ST_OMP_MASKED_TASKLOOP_SIMD
:
2807 p
= "!$OMP MASKED TASKLOOP SIMD";
2812 case ST_OMP_MASTER_TASKLOOP
:
2813 p
= "!$OMP MASTER TASKLOOP";
2815 case ST_OMP_MASTER_TASKLOOP_SIMD
:
2816 p
= "!$OMP MASTER TASKLOOP SIMD";
2818 case ST_OMP_ORDERED
:
2819 case ST_OMP_ORDERED_DEPEND
:
2820 p
= "!$OMP ORDERED";
2822 case ST_OMP_NOTHING
:
2823 /* Note: gfc_match_omp_nothing returns ST_NONE. */
2824 p
= "!$OMP NOTHING";
2826 case ST_OMP_PARALLEL
:
2827 p
= "!$OMP PARALLEL";
2829 case ST_OMP_PARALLEL_DO
:
2830 p
= "!$OMP PARALLEL DO";
2832 case ST_OMP_PARALLEL_LOOP
:
2833 p
= "!$OMP PARALLEL LOOP";
2835 case ST_OMP_PARALLEL_DO_SIMD
:
2836 p
= "!$OMP PARALLEL DO SIMD";
2838 case ST_OMP_PARALLEL_MASKED
:
2839 p
= "!$OMP PARALLEL MASKED";
2841 case ST_OMP_PARALLEL_MASKED_TASKLOOP
:
2842 p
= "!$OMP PARALLEL MASKED TASKLOOP";
2844 case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
2845 p
= "!$OMP PARALLEL MASKED TASKLOOP SIMD";
2847 case ST_OMP_PARALLEL_MASTER
:
2848 p
= "!$OMP PARALLEL MASTER";
2850 case ST_OMP_PARALLEL_MASTER_TASKLOOP
:
2851 p
= "!$OMP PARALLEL MASTER TASKLOOP";
2853 case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
2854 p
= "!$OMP PARALLEL MASTER TASKLOOP SIMD";
2856 case ST_OMP_PARALLEL_SECTIONS
:
2857 p
= "!$OMP PARALLEL SECTIONS";
2859 case ST_OMP_PARALLEL_WORKSHARE
:
2860 p
= "!$OMP PARALLEL WORKSHARE";
2862 case ST_OMP_REQUIRES
:
2863 p
= "!$OMP REQUIRES";
2871 case ST_OMP_SECTIONS
:
2872 p
= "!$OMP SECTIONS";
2874 case ST_OMP_SECTION
:
2875 p
= "!$OMP SECTION";
2886 case ST_OMP_TARGET_DATA
:
2887 p
= "!$OMP TARGET DATA";
2889 case ST_OMP_TARGET_ENTER_DATA
:
2890 p
= "!$OMP TARGET ENTER DATA";
2892 case ST_OMP_TARGET_EXIT_DATA
:
2893 p
= "!$OMP TARGET EXIT DATA";
2895 case ST_OMP_TARGET_PARALLEL
:
2896 p
= "!$OMP TARGET PARALLEL";
2898 case ST_OMP_TARGET_PARALLEL_DO
:
2899 p
= "!$OMP TARGET PARALLEL DO";
2901 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
2902 p
= "!$OMP TARGET PARALLEL DO SIMD";
2904 case ST_OMP_TARGET_PARALLEL_LOOP
:
2905 p
= "!$OMP TARGET PARALLEL LOOP";
2907 case ST_OMP_TARGET_SIMD
:
2908 p
= "!$OMP TARGET SIMD";
2910 case ST_OMP_TARGET_TEAMS
:
2911 p
= "!$OMP TARGET TEAMS";
2913 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
2914 p
= "!$OMP TARGET TEAMS DISTRIBUTE";
2916 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2917 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2919 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2920 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2922 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2923 p
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2925 case ST_OMP_TARGET_TEAMS_LOOP
:
2926 p
= "!$OMP TARGET TEAMS LOOP";
2928 case ST_OMP_TARGET_UPDATE
:
2929 p
= "!$OMP TARGET UPDATE";
2934 case ST_OMP_TASKGROUP
:
2935 p
= "!$OMP TASKGROUP";
2937 case ST_OMP_TASKLOOP
:
2938 p
= "!$OMP TASKLOOP";
2940 case ST_OMP_TASKLOOP_SIMD
:
2941 p
= "!$OMP TASKLOOP SIMD";
2943 case ST_OMP_TASKWAIT
:
2944 p
= "!$OMP TASKWAIT";
2946 case ST_OMP_TASKYIELD
:
2947 p
= "!$OMP TASKYIELD";
2952 case ST_OMP_TEAMS_DISTRIBUTE
:
2953 p
= "!$OMP TEAMS DISTRIBUTE";
2955 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2956 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2958 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2959 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2961 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
2962 p
= "!$OMP TEAMS DISTRIBUTE SIMD";
2964 case ST_OMP_TEAMS_LOOP
:
2965 p
= "!$OMP TEAMS LOOP";
2967 case ST_OMP_THREADPRIVATE
:
2968 p
= "!$OMP THREADPRIVATE";
2970 case ST_OMP_WORKSHARE
:
2971 p
= "!$OMP WORKSHARE";
2974 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2977 if (strip_sentinel
&& p
[0] == '!')
2978 return p
+ strlen ("!$OMP ");
2983 /* Create a symbol for the main program and assign it to ns->proc_name. */
2986 main_program_symbol (gfc_namespace
*ns
, const char *name
)
2988 gfc_symbol
*main_program
;
2989 symbol_attribute attr
;
2991 gfc_get_symbol (name
, ns
, &main_program
);
2992 gfc_clear_attr (&attr
);
2993 attr
.flavor
= FL_PROGRAM
;
2994 attr
.proc
= PROC_UNKNOWN
;
2995 attr
.subroutine
= 1;
2996 attr
.access
= ACCESS_PUBLIC
;
2997 attr
.is_main_program
= 1;
2998 main_program
->attr
= attr
;
2999 main_program
->declared_at
= gfc_current_locus
;
3000 ns
->proc_name
= main_program
;
3001 gfc_commit_symbols ();
3005 /* Do whatever is necessary to accept the last statement. */
3008 accept_statement (gfc_statement st
)
3012 case ST_IMPLICIT_NONE
:
3020 gfc_current_ns
->proc_name
= gfc_new_block
;
3023 /* If the statement is the end of a block, lay down a special code
3024 that allows a branch to the end of the block from within the
3025 construct. IF and SELECT are treated differently from DO
3026 (where EXEC_NOP is added inside the loop) for two
3028 1. END DO has a meaning in the sense that after a GOTO to
3029 it, the loop counter must be increased.
3030 2. IF blocks and SELECT blocks can consist of multiple
3031 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
3032 Putting the label before the END IF would make the jump
3033 from, say, the ELSE IF block to the END IF illegal. */
3037 case ST_END_CRITICAL
:
3038 if (gfc_statement_label
!= NULL
)
3040 new_st
.op
= EXEC_END_NESTED_BLOCK
;
3045 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
3046 one parallel block. Thus, we add the special code to the nested block
3047 itself, instead of the parent one. */
3049 case ST_END_ASSOCIATE
:
3050 if (gfc_statement_label
!= NULL
)
3052 new_st
.op
= EXEC_END_BLOCK
;
3057 /* The end-of-program unit statements do not get the special
3058 marker and require a statement of some sort if they are a
3061 case ST_END_PROGRAM
:
3062 case ST_END_FUNCTION
:
3063 case ST_END_SUBROUTINE
:
3064 if (gfc_statement_label
!= NULL
)
3066 new_st
.op
= EXEC_RETURN
;
3071 new_st
.op
= EXEC_END_PROCEDURE
;
3087 gfc_commit_symbols ();
3088 gfc_warning_check ();
3089 gfc_clear_new_st ();
3093 /* Undo anything tentative that has been built for the current statement,
3094 except if a gfc_charlen structure has been added to current namespace's
3095 list of gfc_charlen structure. */
3098 reject_statement (void)
3100 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
3101 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
3102 gfc_drop_interface_elements_before (current_interface_ptr
,
3103 previous_interface_head
);
3105 gfc_reject_data (gfc_current_ns
);
3107 gfc_new_block
= NULL
;
3108 gfc_undo_symbols ();
3109 gfc_clear_warning ();
3110 undo_new_statement ();
3114 /* Generic complaint about an out of order statement. We also do
3115 whatever is necessary to clean up. */
3118 unexpected_statement (gfc_statement st
)
3120 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
3122 reject_statement ();
3126 /* Given the next statement seen by the matcher, make sure that it is
3127 in proper order with the last. This subroutine is initialized by
3128 calling it with an argument of ST_NONE. If there is a problem, we
3129 issue an error and return false. Otherwise we return true.
3131 Individual parsers need to verify that the statements seen are
3132 valid before calling here, i.e., ENTRY statements are not allowed in
3133 INTERFACE blocks. The following diagram is taken from the standard:
3135 +---------------------------------------+
3136 | program subroutine function module |
3137 +---------------------------------------+
3139 +---------------------------------------+
3141 +---------------------------------------+
3143 | +-----------+------------------+
3144 | | parameter | implicit |
3145 | +-----------+------------------+
3146 | format | | derived type |
3147 | entry | parameter | interface |
3148 | | data | specification |
3149 | | | statement func |
3150 | +-----------+------------------+
3151 | | data | executable |
3152 +--------+-----------+------------------+
3154 +---------------------------------------+
3155 | internal module/subprogram |
3156 +---------------------------------------+
3158 +---------------------------------------+
3167 ORDER_IMPLICIT_NONE
,
3175 enum state_order state
;
3176 gfc_statement last_statement
;
3182 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
3188 p
->state
= ORDER_START
;
3189 in_exec_part
= false;
3193 if (p
->state
> ORDER_USE
)
3195 p
->state
= ORDER_USE
;
3199 if (p
->state
> ORDER_IMPORT
)
3201 p
->state
= ORDER_IMPORT
;
3204 case ST_IMPLICIT_NONE
:
3205 if (p
->state
> ORDER_IMPLICIT
)
3208 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
3209 statement disqualifies a USE but not an IMPLICIT NONE.
3210 Duplicate IMPLICIT NONEs are caught when the implicit types
3213 p
->state
= ORDER_IMPLICIT_NONE
;
3217 if (p
->state
> ORDER_IMPLICIT
)
3219 p
->state
= ORDER_IMPLICIT
;
3224 if (p
->state
< ORDER_IMPLICIT_NONE
)
3225 p
->state
= ORDER_IMPLICIT_NONE
;
3229 if (p
->state
>= ORDER_EXEC
)
3231 if (p
->state
< ORDER_IMPLICIT
)
3232 p
->state
= ORDER_IMPLICIT
;
3236 if (p
->state
< ORDER_SPEC
)
3237 p
->state
= ORDER_SPEC
;
3242 case ST_STRUCTURE_DECL
:
3243 case ST_DERIVED_DECL
:
3245 if (p
->state
>= ORDER_EXEC
)
3247 if (p
->state
< ORDER_SPEC
)
3248 p
->state
= ORDER_SPEC
;
3252 /* The OpenMP/OpenACC directives have to be somewhere in the specification
3253 part, but there are no further requirements on their ordering.
3254 Thus don't adjust p->state, just ignore them. */
3255 if (p
->state
>= ORDER_EXEC
)
3261 if (p
->state
< ORDER_EXEC
)
3262 p
->state
= ORDER_EXEC
;
3263 in_exec_part
= true;
3270 /* All is well, record the statement in case we need it next time. */
3271 p
->where
= gfc_current_locus
;
3272 p
->last_statement
= st
;
3277 gfc_error ("%s statement at %C cannot follow %s statement at %L",
3278 gfc_ascii_statement (st
),
3279 gfc_ascii_statement (p
->last_statement
), &p
->where
);
3285 /* Handle an unexpected end of file. This is a show-stopper... */
3287 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
3290 unexpected_eof (void)
3294 gfc_error ("Unexpected end of file in %qs", gfc_source_file
);
3296 /* Memory cleanup. Move to "second to last". */
3297 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
3300 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
3303 longjmp (eof_buf
, 1);
3305 /* Avoids build error on systems where longjmp is not declared noreturn. */
3310 /* Parse the CONTAINS section of a derived type definition. */
3312 gfc_access gfc_typebound_default_access
;
3315 parse_derived_contains (void)
3318 bool seen_private
= false;
3319 bool seen_comps
= false;
3320 bool error_flag
= false;
3323 gcc_assert (gfc_current_state () == COMP_DERIVED
);
3324 gcc_assert (gfc_current_block ());
3326 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
3328 if (gfc_current_block ()->attr
.sequence
)
3329 gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
3330 " section at %C", gfc_current_block ()->name
);
3331 if (gfc_current_block ()->attr
.is_bind_c
)
3332 gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
3333 " section at %C", gfc_current_block ()->name
);
3335 accept_statement (ST_CONTAINS
);
3336 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
3338 gfc_typebound_default_access
= ACCESS_PUBLIC
;
3344 st
= next_statement ();
3352 gfc_error ("Components in TYPE at %C must precede CONTAINS");
3356 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
3359 accept_statement (ST_PROCEDURE
);
3364 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
3367 accept_statement (ST_GENERIC
);
3372 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
3376 accept_statement (ST_FINAL
);
3384 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
3385 "at %C with empty CONTAINS section")))
3388 /* ST_END_TYPE is accepted by parse_derived after return. */
3392 if (!gfc_find_state (COMP_MODULE
))
3394 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3401 gfc_error ("PRIVATE statement at %C must precede procedure"
3408 gfc_error ("Duplicate PRIVATE statement at %C");
3412 accept_statement (ST_PRIVATE
);
3413 gfc_typebound_default_access
= ACCESS_PRIVATE
;
3414 seen_private
= true;
3418 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
3422 gfc_error ("Already inside a CONTAINS block at %C");
3426 unexpected_statement (st
);
3434 reject_statement ();
3438 gcc_assert (gfc_current_state () == COMP_DERIVED
);
3444 /* Set attributes for the parent symbol based on the attributes of a component
3445 and raise errors if conflicting attributes are found for the component. */
3448 check_component (gfc_symbol
*sym
, gfc_component
*c
, gfc_component
**lockp
,
3449 gfc_component
**eventp
)
3451 bool coarray
, lock_type
, event_type
, allocatable
, pointer
;
3452 coarray
= lock_type
= event_type
= allocatable
= pointer
= false;
3453 gfc_component
*lock_comp
= NULL
, *event_comp
= NULL
;
3455 if (lockp
) lock_comp
= *lockp
;
3456 if (eventp
) event_comp
= *eventp
;
3458 /* Look for allocatable components. */
3459 if (c
->attr
.allocatable
3460 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3461 && CLASS_DATA (c
)->attr
.allocatable
)
3462 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
3463 && c
->ts
.u
.derived
->attr
.alloc_comp
))
3466 sym
->attr
.alloc_comp
= 1;
3469 /* Look for pointer components. */
3471 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3472 && CLASS_DATA (c
)->attr
.class_pointer
)
3473 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
3476 sym
->attr
.pointer_comp
= 1;
3479 /* Look for procedure pointer components. */
3480 if (c
->attr
.proc_pointer
3481 || (c
->ts
.type
== BT_DERIVED
3482 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
3483 sym
->attr
.proc_pointer_comp
= 1;
3485 /* Looking for coarray components. */
3486 if (c
->attr
.codimension
3487 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3488 && CLASS_DATA (c
)->attr
.codimension
))
3491 sym
->attr
.coarray_comp
= 1;
3494 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
3495 && !c
->attr
.pointer
)
3498 sym
->attr
.coarray_comp
= 1;
3501 /* Looking for lock_type components. */
3502 if ((c
->ts
.type
== BT_DERIVED
3503 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3504 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3505 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3506 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
3507 == INTMOD_ISO_FORTRAN_ENV
3508 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
3509 == ISOFORTRAN_LOCK_TYPE
)
3510 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
3511 && !allocatable
&& !pointer
))
3515 sym
->attr
.lock_comp
= 1;
3518 /* Looking for event_type components. */
3519 if ((c
->ts
.type
== BT_DERIVED
3520 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3521 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
3522 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3523 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
3524 == INTMOD_ISO_FORTRAN_ENV
3525 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
3526 == ISOFORTRAN_EVENT_TYPE
)
3527 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.event_comp
3528 && !allocatable
&& !pointer
))
3532 sym
->attr
.event_comp
= 1;
3535 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
3536 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
3537 unless there are nondirect [allocatable or pointer] components
3538 involved (cf. 1.3.33.1 and 1.3.33.3). */
3540 if (pointer
&& !coarray
&& lock_type
)
3541 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
3542 "codimension or be a subcomponent of a coarray, "
3543 "which is not possible as the component has the "
3544 "pointer attribute", c
->name
, &c
->loc
);
3545 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
3546 && c
->ts
.u
.derived
->attr
.lock_comp
)
3547 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3548 "of type LOCK_TYPE, which must have a codimension or be a "
3549 "subcomponent of a coarray", c
->name
, &c
->loc
);
3551 if (lock_type
&& allocatable
&& !coarray
)
3552 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
3553 "a codimension", c
->name
, &c
->loc
);
3554 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
3555 && c
->ts
.u
.derived
->attr
.lock_comp
)
3556 gfc_error ("Allocatable component %s at %L must have a codimension as "
3557 "it has a noncoarray subcomponent of type LOCK_TYPE",
3560 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
3561 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3562 "subcomponent of type LOCK_TYPE must have a codimension or "
3563 "be a subcomponent of a coarray. (Variables of type %s may "
3564 "not have a codimension as already a coarray "
3565 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
3567 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
3568 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3569 "subcomponent of type LOCK_TYPE must have a codimension or "
3570 "be a subcomponent of a coarray. (Variables of type %s may "
3571 "not have a codimension as %s at %L has a codimension or a "
3572 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
3573 sym
->name
, c
->name
, &c
->loc
);
3575 /* Similarly for EVENT TYPE. */
3577 if (pointer
&& !coarray
&& event_type
)
3578 gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
3579 "codimension or be a subcomponent of a coarray, "
3580 "which is not possible as the component has the "
3581 "pointer attribute", c
->name
, &c
->loc
);
3582 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
3583 && c
->ts
.u
.derived
->attr
.event_comp
)
3584 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3585 "of type EVENT_TYPE, which must have a codimension or be a "
3586 "subcomponent of a coarray", c
->name
, &c
->loc
);
3588 if (event_type
&& allocatable
&& !coarray
)
3589 gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
3590 "a codimension", c
->name
, &c
->loc
);
3591 else if (event_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
3592 && c
->ts
.u
.derived
->attr
.event_comp
)
3593 gfc_error ("Allocatable component %s at %L must have a codimension as "
3594 "it has a noncoarray subcomponent of type EVENT_TYPE",
3597 if (sym
->attr
.coarray_comp
&& !coarray
&& event_type
)
3598 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3599 "subcomponent of type EVENT_TYPE must have a codimension or "
3600 "be a subcomponent of a coarray. (Variables of type %s may "
3601 "not have a codimension as already a coarray "
3602 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
3604 if (sym
->attr
.event_comp
&& coarray
&& !event_type
)
3605 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3606 "subcomponent of type EVENT_TYPE must have a codimension or "
3607 "be a subcomponent of a coarray. (Variables of type %s may "
3608 "not have a codimension as %s at %L has a codimension or a "
3609 "coarray subcomponent)", event_comp
->name
, &event_comp
->loc
,
3610 sym
->name
, c
->name
, &c
->loc
);
3612 /* Look for private components. */
3613 if (sym
->component_access
== ACCESS_PRIVATE
3614 || c
->attr
.access
== ACCESS_PRIVATE
3615 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
3616 sym
->attr
.private_comp
= 1;
3618 if (lockp
) *lockp
= lock_comp
;
3619 if (eventp
) *eventp
= event_comp
;
3623 static void parse_struct_map (gfc_statement
);
3625 /* Parse a union component definition within a structure definition. */
3633 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3636 accept_statement(ST_UNION
);
3637 push_state (&s
, COMP_UNION
, gfc_new_block
);
3644 st
= next_statement ();
3645 /* Only MAP declarations valid within a union. */
3652 accept_statement (ST_MAP
);
3653 parse_struct_map (ST_MAP
);
3654 /* Add a component to the union for each map. */
3655 if (!gfc_add_component (un
, gfc_new_block
->name
, &c
))
3657 gfc_internal_error ("failed to create map component '%s'",
3658 gfc_new_block
->name
);
3659 reject_statement ();
3662 c
->ts
.type
= BT_DERIVED
;
3663 c
->ts
.u
.derived
= gfc_new_block
;
3664 /* Normally components get their initialization expressions when they
3665 are created in decl.cc (build_struct) so we can look through the
3666 flat component list for initializers during resolution. Unions and
3667 maps create components along with their type definitions so we
3668 have to generate initializers here. */
3669 c
->initializer
= gfc_default_initializer (&c
->ts
);
3674 accept_statement (ST_END_UNION
);
3678 unexpected_statement (st
);
3683 for (c
= un
->components
; c
; c
= c
->next
)
3684 check_component (un
, c
, &lock_comp
, &event_comp
);
3686 /* Add the union as a component in its parent structure. */
3688 if (!gfc_add_component (gfc_current_block (), un
->name
, &c
))
3690 gfc_internal_error ("failed to create union component '%s'", un
->name
);
3691 reject_statement ();
3694 c
->ts
.type
= BT_UNION
;
3695 c
->ts
.u
.derived
= un
;
3696 c
->initializer
= gfc_default_initializer (&c
->ts
);
3698 un
->attr
.zero_comp
= un
->components
== NULL
;
3702 /* Parse a STRUCTURE or MAP. */
3705 parse_struct_map (gfc_statement block
)
3711 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3712 gfc_compile_state comp
;
3715 if (block
== ST_STRUCTURE_DECL
)
3717 comp
= COMP_STRUCTURE
;
3718 ends
= ST_END_STRUCTURE
;
3722 gcc_assert (block
== ST_MAP
);
3727 accept_statement(block
);
3728 push_state (&s
, comp
, gfc_new_block
);
3730 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3733 while (compiling_type
)
3735 st
= next_statement ();
3741 /* Nested structure declarations will be captured as ST_DATA_DECL. */
3742 case ST_STRUCTURE_DECL
:
3743 /* Let a more specific error make it to decode_statement(). */
3744 if (gfc_error_check () == 0)
3745 gfc_error ("Syntax error in nested structure declaration at %C");
3746 reject_statement ();
3747 /* Skip the rest of this statement. */
3748 gfc_error_recovery ();
3752 accept_statement (ST_UNION
);
3757 /* The data declaration was a nested/ad-hoc STRUCTURE field. */
3758 accept_statement (ST_DATA_DECL
);
3759 if (gfc_new_block
&& gfc_new_block
!= gfc_current_block ()
3760 && gfc_new_block
->attr
.flavor
== FL_STRUCT
)
3761 parse_struct_map (ST_STRUCTURE_DECL
);
3764 case ST_END_STRUCTURE
:
3768 accept_statement (st
);
3772 unexpected_statement (st
);
3776 unexpected_statement (st
);
3781 /* Validate each component. */
3782 sym
= gfc_current_block ();
3783 for (c
= sym
->components
; c
; c
= c
->next
)
3784 check_component (sym
, c
, &lock_comp
, &event_comp
);
3786 sym
->attr
.zero_comp
= (sym
->components
== NULL
);
3788 /* Allow parse_union to find this structure to add to its list of maps. */
3789 if (block
== ST_MAP
)
3790 gfc_new_block
= gfc_current_block ();
3796 /* Parse a derived type. */
3799 parse_derived (void)
3801 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
3805 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3807 accept_statement (ST_DERIVED_DECL
);
3808 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
3810 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3817 while (compiling_type
)
3819 st
= next_statement ();
3827 accept_statement (st
);
3832 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
3839 if (!seen_component
)
3840 gfc_notify_std (GFC_STD_F2003
, "Derived type "
3841 "definition at %C without components");
3843 accept_statement (ST_END_TYPE
);
3847 if (!gfc_find_state (COMP_MODULE
))
3849 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3856 gfc_error ("PRIVATE statement at %C must precede "
3857 "structure components");
3862 gfc_error ("Duplicate PRIVATE statement at %C");
3864 s
.sym
->component_access
= ACCESS_PRIVATE
;
3866 accept_statement (ST_PRIVATE
);
3873 gfc_error ("SEQUENCE statement at %C must precede "
3874 "structure components");
3878 if (gfc_current_block ()->attr
.sequence
)
3879 gfc_warning (0, "SEQUENCE attribute at %C already specified in "
3884 gfc_error ("Duplicate SEQUENCE statement at %C");
3888 gfc_add_sequence (&gfc_current_block ()->attr
,
3889 gfc_current_block ()->name
, NULL
);
3893 gfc_notify_std (GFC_STD_F2003
,
3894 "CONTAINS block in derived type"
3895 " definition at %C");
3897 accept_statement (ST_CONTAINS
);
3898 parse_derived_contains ();
3902 unexpected_statement (st
);
3907 /* need to verify that all fields of the derived type are
3908 * interoperable with C if the type is declared to be bind(c)
3910 sym
= gfc_current_block ();
3911 for (c
= sym
->components
; c
; c
= c
->next
)
3912 check_component (sym
, c
, &lock_comp
, &event_comp
);
3914 if (!seen_component
)
3915 sym
->attr
.zero_comp
= 1;
3921 /* Parse an ENUM. */
3929 int seen_enumerator
= 0;
3931 push_state (&s
, COMP_ENUM
, gfc_new_block
);
3935 while (compiling_enum
)
3937 st
= next_statement ();
3945 seen_enumerator
= 1;
3946 accept_statement (st
);
3951 if (!seen_enumerator
)
3952 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
3953 accept_statement (st
);
3957 gfc_free_enum_history ();
3958 unexpected_statement (st
);
3966 /* Parse an interface. We must be able to deal with the possibility
3967 of recursive interfaces. The parse_spec() subroutine is mutually
3968 recursive with parse_interface(). */
3970 static gfc_statement
parse_spec (gfc_statement
);
3973 parse_interface (void)
3975 gfc_compile_state new_state
= COMP_NONE
, current_state
;
3976 gfc_symbol
*prog_unit
, *sym
;
3977 gfc_interface_info save
;
3978 gfc_state_data s1
, s2
;
3981 accept_statement (ST_INTERFACE
);
3983 current_interface
.ns
= gfc_current_ns
;
3984 save
= current_interface
;
3986 sym
= (current_interface
.type
== INTERFACE_GENERIC
3987 || current_interface
.type
== INTERFACE_USER_OP
)
3988 ? gfc_new_block
: NULL
;
3990 push_state (&s1
, COMP_INTERFACE
, sym
);
3991 current_state
= COMP_NONE
;
3994 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
3996 st
= next_statement ();
4004 if (st
== ST_SUBROUTINE
)
4005 new_state
= COMP_SUBROUTINE
;
4006 else if (st
== ST_FUNCTION
)
4007 new_state
= COMP_FUNCTION
;
4008 if (gfc_new_block
->attr
.pointer
)
4010 gfc_new_block
->attr
.pointer
= 0;
4011 gfc_new_block
->attr
.proc_pointer
= 1;
4013 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
4014 gfc_new_block
->formal
, NULL
))
4016 reject_statement ();
4017 gfc_free_namespace (gfc_current_ns
);
4020 /* F2008 C1210 forbids the IMPORT statement in module procedure
4021 interface bodies and the flag is set to import symbols. */
4022 if (gfc_new_block
->attr
.module_procedure
)
4023 gfc_current_ns
->has_import_set
= 1;
4027 case ST_MODULE_PROC
: /* The module procedure matcher makes
4028 sure the context is correct. */
4029 accept_statement (st
);
4030 gfc_free_namespace (gfc_current_ns
);
4033 case ST_END_INTERFACE
:
4034 gfc_free_namespace (gfc_current_ns
);
4035 gfc_current_ns
= current_interface
.ns
;
4039 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
4040 gfc_ascii_statement (st
));
4041 reject_statement ();
4042 gfc_free_namespace (gfc_current_ns
);
4047 /* Make sure that the generic name has the right attribute. */
4048 if (current_interface
.type
== INTERFACE_GENERIC
4049 && current_state
== COMP_NONE
)
4051 if (new_state
== COMP_FUNCTION
&& sym
)
4052 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
4053 else if (new_state
== COMP_SUBROUTINE
&& sym
)
4054 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
4056 current_state
= new_state
;
4059 if (current_interface
.type
== INTERFACE_ABSTRACT
)
4061 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
4062 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
4063 gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
4064 "cannot be the same as an intrinsic type",
4065 gfc_new_block
->name
);
4068 push_state (&s2
, new_state
, gfc_new_block
);
4069 accept_statement (st
);
4070 prog_unit
= gfc_new_block
;
4071 prog_unit
->formal_ns
= gfc_current_ns
;
4074 /* Read data declaration statements. */
4075 st
= parse_spec (ST_NONE
);
4076 in_specification_block
= true;
4078 /* Since the interface block does not permit an IMPLICIT statement,
4079 the default type for the function or the result must be taken
4080 from the formal namespace. */
4081 if (new_state
== COMP_FUNCTION
)
4083 if (prog_unit
->result
== prog_unit
4084 && prog_unit
->ts
.type
== BT_UNKNOWN
)
4085 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
4086 else if (prog_unit
->result
!= prog_unit
4087 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
4088 gfc_set_default_type (prog_unit
->result
, 1,
4089 prog_unit
->formal_ns
);
4092 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
4094 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
4095 gfc_ascii_statement (st
));
4096 reject_statement ();
4100 /* Add EXTERNAL attribute to function or subroutine. */
4101 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
4102 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
4104 current_interface
= save
;
4105 gfc_add_interface (prog_unit
);
4108 if (current_interface
.ns
4109 && current_interface
.ns
->proc_name
4110 && strcmp (current_interface
.ns
->proc_name
->name
,
4111 prog_unit
->name
) == 0)
4112 gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
4113 "enclosing procedure", prog_unit
->name
,
4114 ¤t_interface
.ns
->proc_name
->declared_at
);
4123 /* Associate function characteristics by going back to the function
4124 declaration and rematching the prefix. */
4127 match_deferred_characteristics (gfc_typespec
* ts
)
4130 match m
= MATCH_ERROR
;
4131 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4133 loc
= gfc_current_locus
;
4135 gfc_current_locus
= gfc_current_block ()->declared_at
;
4138 gfc_buffer_error (true);
4139 m
= gfc_match_prefix (ts
);
4140 gfc_buffer_error (false);
4142 if (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
)
4150 /* Only permit one go at the characteristic association. */
4154 /* Set the function locus correctly. If we have not found the
4155 function name, there is an error. */
4157 && gfc_match ("function% %n", name
) == MATCH_YES
4158 && strcmp (name
, gfc_current_block ()->name
) == 0)
4160 gfc_current_block ()->declared_at
= gfc_current_locus
;
4161 gfc_commit_symbols ();
4166 gfc_undo_symbols ();
4169 gfc_current_locus
=loc
;
4174 /* Check specification-expressions in the function result of the currently
4175 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
4176 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
4177 scope are not yet parsed so this has to be delayed up to parse_spec. */
4180 check_function_result_typed (void)
4184 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
4186 if (!gfc_current_ns
->proc_name
->result
)
4189 ts
= gfc_current_ns
->proc_name
->result
->ts
;
4191 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
4192 /* TODO: Extend when KIND type parameters are implemented. */
4193 if (ts
.type
== BT_CHARACTER
&& ts
.u
.cl
&& ts
.u
.cl
->length
)
4195 /* Reject invalid type of specification expression for length. */
4196 if (ts
.u
.cl
->length
->ts
.type
!= BT_INTEGER
)
4199 gfc_expr_check_typed (ts
.u
.cl
->length
, gfc_current_ns
, true);
4206 /* Parse a set of specification statements. Returns the statement
4207 that doesn't fit. */
4209 static gfc_statement
4210 parse_spec (gfc_statement st
)
4213 bool function_result_typed
= false;
4214 bool bad_characteristic
= false;
4217 in_specification_block
= true;
4219 verify_st_order (&ss
, ST_NONE
, false);
4221 st
= next_statement ();
4223 /* If we are not inside a function or don't have a result specified so far,
4224 do nothing special about it. */
4225 if (gfc_current_state () != COMP_FUNCTION
)
4226 function_result_typed
= true;
4229 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
4232 if (proc
->result
&& proc
->result
->ts
.type
== BT_UNKNOWN
)
4233 function_result_typed
= true;
4238 /* If we're inside a BLOCK construct, some statements are disallowed.
4239 Check this here. Attribute declaration statements like INTENT, OPTIONAL
4240 or VALUE are also disallowed, but they don't have a particular ST_*
4241 key so we have to check for them individually in their matcher routine. */
4242 if (gfc_current_state () == COMP_BLOCK
)
4246 case ST_IMPLICIT_NONE
:
4249 case ST_EQUIVALENCE
:
4250 case ST_STATEMENT_FUNCTION
:
4251 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
4252 gfc_ascii_statement (st
));
4253 reject_statement ();
4259 else if (gfc_current_state () == COMP_BLOCK_DATA
)
4260 /* Fortran 2008, C1116. */
4267 case ST_DERIVED_DECL
:
4268 case ST_END_BLOCK_DATA
:
4269 case ST_EQUIVALENCE
:
4271 case ST_IMPLICIT_NONE
:
4272 case ST_OMP_THREADPRIVATE
:
4274 case ST_STRUCTURE_DECL
:
4283 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
4284 gfc_ascii_statement (st
));
4285 reject_statement ();
4289 /* If we find a statement that cannot be followed by an IMPLICIT statement
4290 (and thus we can expect to see none any further), type the function result
4291 if it has not yet been typed. Be careful not to give the END statement
4292 to verify_st_order! */
4293 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
4295 bool verify_now
= false;
4297 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
4302 verify_st_order (&dummyss
, ST_NONE
, false);
4303 verify_st_order (&dummyss
, st
, false);
4305 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
4310 function_result_typed
= check_function_result_typed ();
4318 case ST_IMPLICIT_NONE
:
4320 if (!function_result_typed
)
4321 function_result_typed
= check_function_result_typed ();
4326 case ST_DATA
: /* Not allowed in interfaces */
4327 if (gfc_current_state () == COMP_INTERFACE
)
4337 case ST_STRUCTURE_DECL
:
4338 case ST_DERIVED_DECL
:
4342 if (!verify_st_order (&ss
, st
, false))
4344 reject_statement ();
4345 st
= next_statement ();
4355 case ST_STRUCTURE_DECL
:
4356 parse_struct_map (ST_STRUCTURE_DECL
);
4359 case ST_DERIVED_DECL
:
4365 if (gfc_current_state () != COMP_MODULE
)
4367 gfc_error ("%s statement must appear in a MODULE",
4368 gfc_ascii_statement (st
));
4369 reject_statement ();
4373 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
4375 gfc_error ("%s statement at %C follows another accessibility "
4376 "specification", gfc_ascii_statement (st
));
4377 reject_statement ();
4381 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
4382 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
4386 case ST_STATEMENT_FUNCTION
:
4387 if (gfc_current_state () == COMP_MODULE
4388 || gfc_current_state () == COMP_SUBMODULE
)
4390 unexpected_statement (st
);
4398 accept_statement (st
);
4399 st
= next_statement ();
4403 accept_statement (st
);
4405 st
= next_statement ();
4408 case ST_GET_FCN_CHARACTERISTICS
:
4409 /* This statement triggers the association of a function's result
4411 ts
= &gfc_current_block ()->result
->ts
;
4412 if (match_deferred_characteristics (ts
) != MATCH_YES
)
4413 bad_characteristic
= true;
4415 st
= next_statement ();
4422 /* If match_deferred_characteristics failed, then there is an error. */
4423 if (bad_characteristic
)
4425 ts
= &gfc_current_block ()->result
->ts
;
4426 if (ts
->type
!= BT_DERIVED
&& ts
->type
!= BT_CLASS
)
4427 gfc_error ("Bad kind expression for function %qs at %L",
4428 gfc_current_block ()->name
,
4429 &gfc_current_block ()->declared_at
);
4431 gfc_error ("The type for function %qs at %L is not accessible",
4432 gfc_current_block ()->name
,
4433 &gfc_current_block ()->declared_at
);
4435 gfc_current_block ()->ts
.kind
= 0;
4436 /* Keep the derived type; if it's bad, it will be discovered later. */
4437 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
4438 ts
->type
= BT_UNKNOWN
;
4441 in_specification_block
= false;
4447 /* Parse a WHERE block, (not a simple WHERE statement). */
4450 parse_where_block (void)
4452 int seen_empty_else
;
4457 accept_statement (ST_WHERE_BLOCK
);
4458 top
= gfc_state_stack
->tail
;
4460 push_state (&s
, COMP_WHERE
, gfc_new_block
);
4462 d
= add_statement ();
4463 d
->expr1
= top
->expr1
;
4469 seen_empty_else
= 0;
4473 st
= next_statement ();
4479 case ST_WHERE_BLOCK
:
4480 parse_where_block ();
4485 accept_statement (st
);
4489 if (seen_empty_else
)
4491 gfc_error ("ELSEWHERE statement at %C follows previous "
4492 "unmasked ELSEWHERE");
4493 reject_statement ();
4497 if (new_st
.expr1
== NULL
)
4498 seen_empty_else
= 1;
4500 d
= new_level (gfc_state_stack
->head
);
4502 d
->expr1
= new_st
.expr1
;
4504 accept_statement (st
);
4509 accept_statement (st
);
4513 gfc_error ("Unexpected %s statement in WHERE block at %C",
4514 gfc_ascii_statement (st
));
4515 reject_statement ();
4519 while (st
!= ST_END_WHERE
);
4525 /* Parse a FORALL block (not a simple FORALL statement). */
4528 parse_forall_block (void)
4534 accept_statement (ST_FORALL_BLOCK
);
4535 top
= gfc_state_stack
->tail
;
4537 push_state (&s
, COMP_FORALL
, gfc_new_block
);
4539 d
= add_statement ();
4540 d
->op
= EXEC_FORALL
;
4545 st
= next_statement ();
4550 case ST_POINTER_ASSIGNMENT
:
4553 accept_statement (st
);
4556 case ST_WHERE_BLOCK
:
4557 parse_where_block ();
4560 case ST_FORALL_BLOCK
:
4561 parse_forall_block ();
4565 accept_statement (st
);
4572 gfc_error ("Unexpected %s statement in FORALL block at %C",
4573 gfc_ascii_statement (st
));
4575 reject_statement ();
4579 while (st
!= ST_END_FORALL
);
4585 static gfc_statement
parse_executable (gfc_statement
);
4587 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
4590 parse_if_block (void)
4599 accept_statement (ST_IF_BLOCK
);
4601 top
= gfc_state_stack
->tail
;
4602 push_state (&s
, COMP_IF
, gfc_new_block
);
4604 new_st
.op
= EXEC_IF
;
4605 d
= add_statement ();
4607 d
->expr1
= top
->expr1
;
4613 st
= parse_executable (ST_NONE
);
4623 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
4624 "statement at %L", &else_locus
);
4626 reject_statement ();
4630 d
= new_level (gfc_state_stack
->head
);
4632 d
->expr1
= new_st
.expr1
;
4634 accept_statement (st
);
4641 gfc_error ("Duplicate ELSE statements at %L and %C",
4643 reject_statement ();
4648 else_locus
= gfc_current_locus
;
4650 d
= new_level (gfc_state_stack
->head
);
4653 accept_statement (st
);
4661 unexpected_statement (st
);
4665 while (st
!= ST_ENDIF
);
4668 accept_statement (st
);
4672 /* Parse a SELECT block. */
4675 parse_select_block (void)
4681 accept_statement (ST_SELECT_CASE
);
4683 cp
= gfc_state_stack
->tail
;
4684 push_state (&s
, COMP_SELECT
, gfc_new_block
);
4686 /* Make sure that the next statement is a CASE or END SELECT. */
4689 st
= next_statement ();
4692 if (st
== ST_END_SELECT
)
4694 /* Empty SELECT CASE is OK. */
4695 accept_statement (st
);
4702 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
4705 reject_statement ();
4708 /* At this point, we've got a nonempty select block. */
4709 cp
= new_level (cp
);
4712 accept_statement (st
);
4716 st
= parse_executable (ST_NONE
);
4723 cp
= new_level (gfc_state_stack
->head
);
4725 gfc_clear_new_st ();
4727 accept_statement (st
);
4733 /* Can't have an executable statement because of
4734 parse_executable(). */
4736 unexpected_statement (st
);
4740 while (st
!= ST_END_SELECT
);
4743 accept_statement (st
);
4747 /* Pop the current selector from the SELECT TYPE stack. */
4750 select_type_pop (void)
4752 gfc_select_type_stack
*old
= select_type_stack
;
4753 select_type_stack
= old
->prev
;
4758 /* Parse a SELECT TYPE construct (F03:R821). */
4761 parse_select_type_block (void)
4767 gfc_current_ns
= new_st
.ext
.block
.ns
;
4768 accept_statement (ST_SELECT_TYPE
);
4770 cp
= gfc_state_stack
->tail
;
4771 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
4773 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
4777 st
= next_statement ();
4780 if (st
== ST_END_SELECT
)
4781 /* Empty SELECT CASE is OK. */
4783 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
4786 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
4787 "following SELECT TYPE at %C");
4789 reject_statement ();
4792 /* At this point, we've got a nonempty select block. */
4793 cp
= new_level (cp
);
4796 accept_statement (st
);
4800 st
= parse_executable (ST_NONE
);
4808 cp
= new_level (gfc_state_stack
->head
);
4810 gfc_clear_new_st ();
4812 accept_statement (st
);
4818 /* Can't have an executable statement because of
4819 parse_executable(). */
4821 unexpected_statement (st
);
4825 while (st
!= ST_END_SELECT
);
4829 accept_statement (st
);
4830 gfc_current_ns
= gfc_current_ns
->parent
;
4835 /* Parse a SELECT RANK construct. */
4838 parse_select_rank_block (void)
4844 gfc_current_ns
= new_st
.ext
.block
.ns
;
4845 accept_statement (ST_SELECT_RANK
);
4847 cp
= gfc_state_stack
->tail
;
4848 push_state (&s
, COMP_SELECT_RANK
, gfc_new_block
);
4850 /* Make sure that the next statement is a RANK IS or RANK DEFAULT. */
4853 st
= next_statement ();
4856 if (st
== ST_END_SELECT
)
4857 /* Empty SELECT CASE is OK. */
4862 gfc_error ("Expected RANK or RANK DEFAULT "
4863 "following SELECT RANK at %C");
4865 reject_statement ();
4868 /* At this point, we've got a nonempty select block. */
4869 cp
= new_level (cp
);
4872 accept_statement (st
);
4876 st
= parse_executable (ST_NONE
);
4883 cp
= new_level (gfc_state_stack
->head
);
4885 gfc_clear_new_st ();
4887 accept_statement (st
);
4893 /* Can't have an executable statement because of
4894 parse_executable(). */
4896 unexpected_statement (st
);
4900 while (st
!= ST_END_SELECT
);
4904 accept_statement (st
);
4905 gfc_current_ns
= gfc_current_ns
->parent
;
4910 /* Given a symbol, make sure it is not an iteration variable for a DO
4911 statement. This subroutine is called when the symbol is seen in a
4912 context that causes it to become redefined. If the symbol is an
4913 iterator, we generate an error message and return nonzero. */
4916 gfc_check_do_variable (gfc_symtree
*st
)
4923 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
4924 if (s
->do_variable
== st
)
4926 gfc_error_now ("Variable %qs at %C cannot be redefined inside "
4927 "loop beginning at %L", st
->name
, &s
->head
->loc
);
4935 /* Checks to see if the current statement label closes an enddo.
4936 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
4937 an error) if it incorrectly closes an ENDDO. */
4940 check_do_closure (void)
4944 if (gfc_statement_label
== NULL
)
4947 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
4948 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4952 return 0; /* No loops to close */
4954 if (p
->ext
.end_do_label
== gfc_statement_label
)
4956 if (p
== gfc_state_stack
)
4959 gfc_error ("End of nonblock DO statement at %C is within another block");
4963 /* At this point, the label doesn't terminate the innermost loop.
4964 Make sure it doesn't terminate another one. */
4965 for (; p
; p
= p
->previous
)
4966 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4967 && p
->ext
.end_do_label
== gfc_statement_label
)
4969 gfc_error ("End of nonblock DO statement at %C is interwoven "
4970 "with another DO loop");
4978 /* Parse a series of contained program units. */
4980 static void parse_progunit (gfc_statement
);
4983 /* Parse a CRITICAL block. */
4986 parse_critical_block (void)
4989 gfc_state_data s
, *sd
;
4992 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4993 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
4994 gfc_error_now (is_oacc (sd
)
4995 ? G_("CRITICAL block inside of OpenACC region at %C")
4996 : G_("CRITICAL block inside of OpenMP region at %C"));
4998 s
.ext
.end_do_label
= new_st
.label1
;
5000 accept_statement (ST_CRITICAL
);
5001 top
= gfc_state_stack
->tail
;
5003 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
5005 d
= add_statement ();
5006 d
->op
= EXEC_CRITICAL
;
5011 st
= parse_executable (ST_NONE
);
5019 case ST_END_CRITICAL
:
5020 if (s
.ext
.end_do_label
!= NULL
5021 && s
.ext
.end_do_label
!= gfc_statement_label
)
5022 gfc_error_now ("Statement label in END CRITICAL at %C does not "
5023 "match CRITICAL label");
5025 if (gfc_statement_label
!= NULL
)
5027 new_st
.op
= EXEC_NOP
;
5033 unexpected_statement (st
);
5037 while (st
!= ST_END_CRITICAL
);
5040 accept_statement (st
);
5044 /* Set up the local namespace for a BLOCK construct. */
5047 gfc_build_block_ns (gfc_namespace
*parent_ns
)
5049 gfc_namespace
* my_ns
;
5050 static int numblock
= 1;
5052 my_ns
= gfc_get_namespace (parent_ns
, 1);
5053 my_ns
->construct_entities
= 1;
5055 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
5056 code generation (so it must not be NULL).
5057 We set its recursive argument if our container procedure is recursive, so
5058 that local variables are accordingly placed on the stack when it
5059 will be necessary. */
5061 my_ns
->proc_name
= gfc_new_block
;
5065 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
5067 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
5068 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
5069 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
5070 my_ns
->proc_name
->name
, NULL
);
5072 gfc_commit_symbol (my_ns
->proc_name
);
5075 if (parent_ns
->proc_name
)
5076 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
5082 /* Parse a BLOCK construct. */
5085 parse_block_construct (void)
5087 gfc_namespace
* my_ns
;
5088 gfc_namespace
* my_parent
;
5091 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
5093 my_ns
= gfc_build_block_ns (gfc_current_ns
);
5095 new_st
.op
= EXEC_BLOCK
;
5096 new_st
.ext
.block
.ns
= my_ns
;
5097 new_st
.ext
.block
.assoc
= NULL
;
5098 accept_statement (ST_BLOCK
);
5100 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
5101 gfc_current_ns
= my_ns
;
5102 my_parent
= my_ns
->parent
;
5104 parse_progunit (ST_NONE
);
5106 /* Don't depend on the value of gfc_current_ns; it might have been
5107 reset if the block had errors and was cleaned up. */
5108 gfc_current_ns
= my_parent
;
5114 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
5115 behind the scenes with compiler-generated variables. */
5118 parse_associate (void)
5120 gfc_namespace
* my_ns
;
5123 gfc_association_list
* a
;
5126 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
5128 my_ns
= gfc_build_block_ns (gfc_current_ns
);
5130 new_st
.op
= EXEC_BLOCK
;
5131 new_st
.ext
.block
.ns
= my_ns
;
5132 gcc_assert (new_st
.ext
.block
.assoc
);
5134 /* Add all associate-names as BLOCK variables. Creating them is enough
5135 for now, they'll get their values during trans-* phase. */
5136 gfc_current_ns
= my_ns
;
5137 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
5139 gfc_symbol
*sym
, *tsym
;
5143 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
5147 sym
->attr
.flavor
= FL_VARIABLE
;
5149 sym
->declared_at
= a
->where
;
5150 gfc_set_sym_referenced (sym
);
5152 /* Initialize the typespec. It is not available in all cases,
5153 however, as it may only be set on the target during resolution.
5154 Still, sometimes it helps to have it right now -- especially
5155 for parsing component references on the associate-name
5156 in case of association to a derived-type. */
5157 sym
->ts
= a
->target
->ts
;
5160 /* Don’t share the character length information between associate
5161 variable and target if the length is not a compile-time constant,
5162 as we don’t want to touch some other character length variable when
5163 we try to initialize the associate variable’s character length
5165 We do it here rather than later so that expressions referencing the
5166 associate variable will automatically have the correctly setup length
5167 information. If we did it at resolution stage the expressions would
5168 use the original length information, and the variable a new different
5169 one, but only the latter one would be correctly initialized at
5170 translation stage, and the former one would need some additional setup
5172 if (sym
->ts
.type
== BT_CHARACTER
5174 && !(sym
->ts
.u
.cl
->length
5175 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
))
5176 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5178 /* Check if the target expression is array valued. This cannot be done
5179 by calling gfc_resolve_expr because the context is unavailable.
5180 However, the references can be resolved and the rank of the target
5182 if (target
->ref
&& gfc_resolve_ref (target
)
5183 && target
->expr_type
!= EXPR_ARRAY
5184 && target
->expr_type
!= EXPR_COMPCALL
)
5185 gfc_expression_rank (target
);
5187 /* Determine whether or not function expressions with unknown type are
5188 structure constructors. If so, the function result can be converted
5189 to be a derived type.
5190 TODO: Deal with references to sibling functions that have not yet been
5191 parsed (PRs 89645 and 99065). */
5192 if (target
->expr_type
== EXPR_FUNCTION
&& target
->ts
.type
== BT_UNKNOWN
)
5194 gfc_symbol
*derived
;
5195 /* The derived type has a leading uppercase character. */
5196 gfc_find_symbol (gfc_dt_upper_string (target
->symtree
->name
),
5197 my_ns
->parent
, 1, &derived
);
5198 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
5200 sym
->ts
.type
= BT_DERIVED
;
5201 sym
->ts
.u
.derived
= derived
;
5203 else if (target
->symtree
&& (tsym
= target
->symtree
->n
.sym
))
5205 sym
->ts
= tsym
->result
? tsym
->result
->ts
: tsym
->ts
;
5206 if (sym
->ts
.type
== BT_CLASS
)
5208 if (CLASS_DATA (sym
)->as
)
5209 target
->rank
= CLASS_DATA (sym
)->as
->rank
;
5210 sym
->attr
.class_ok
= 1;
5215 rank
= target
->rank
;
5216 /* Fixup cases where the ranks are mismatched. */
5217 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
5219 if ((!CLASS_DATA (sym
)->as
&& rank
!= 0)
5220 || (CLASS_DATA (sym
)->as
5221 && CLASS_DATA (sym
)->as
->rank
!= rank
))
5223 /* Don't just (re-)set the attr and as in the sym.ts,
5224 because this modifies the target's attr and as. Copy the
5225 data and do a build_class_symbol. */
5226 symbol_attribute attr
= CLASS_DATA (target
)->attr
;
5227 int corank
= gfc_get_corank (target
);
5232 as
= gfc_get_array_spec ();
5233 as
->type
= AS_DEFERRED
;
5235 as
->corank
= corank
;
5236 attr
.dimension
= rank
? 1 : 0;
5237 attr
.codimension
= corank
? 1 : 0;
5242 attr
.dimension
= attr
.codimension
= 0;
5245 type
= CLASS_DATA (sym
)->ts
;
5246 if (!gfc_build_class_symbol (&type
, &attr
, &as
))
5249 sym
->ts
.type
= BT_CLASS
;
5250 sym
->attr
.class_ok
= 1;
5253 sym
->attr
.class_ok
= 1;
5255 else if ((!sym
->as
&& rank
!= 0)
5256 || (sym
->as
&& sym
->as
->rank
!= rank
))
5258 as
= gfc_get_array_spec ();
5259 as
->type
= AS_DEFERRED
;
5261 as
->corank
= gfc_get_corank (target
);
5263 sym
->attr
.dimension
= 1;
5265 sym
->attr
.codimension
= 1;
5269 accept_statement (ST_ASSOCIATE
);
5270 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
5273 st
= parse_executable (ST_NONE
);
5280 accept_statement (st
);
5281 my_ns
->code
= gfc_state_stack
->head
;
5285 unexpected_statement (st
);
5289 gfc_current_ns
= gfc_current_ns
->parent
;
5294 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
5295 handled inside of parse_executable(), because they aren't really
5299 parse_do_block (void)
5308 s
.ext
.end_do_label
= new_st
.label1
;
5310 if (new_st
.ext
.iterator
!= NULL
)
5312 stree
= new_st
.ext
.iterator
->var
->symtree
;
5313 if (directive_unroll
!= -1)
5315 new_st
.ext
.iterator
->unroll
= directive_unroll
;
5316 directive_unroll
= -1;
5318 if (directive_ivdep
)
5320 new_st
.ext
.iterator
->ivdep
= directive_ivdep
;
5321 directive_ivdep
= false;
5323 if (directive_vector
)
5325 new_st
.ext
.iterator
->vector
= directive_vector
;
5326 directive_vector
= false;
5328 if (directive_novector
)
5330 new_st
.ext
.iterator
->novector
= directive_novector
;
5331 directive_novector
= false;
5337 accept_statement (ST_DO
);
5339 top
= gfc_state_stack
->tail
;
5340 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
5343 s
.do_variable
= stree
;
5345 top
->block
= new_level (top
);
5346 top
->block
->op
= EXEC_DO
;
5349 st
= parse_executable (ST_NONE
);
5357 if (s
.ext
.end_do_label
!= NULL
5358 && s
.ext
.end_do_label
!= gfc_statement_label
)
5359 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
5362 if (gfc_statement_label
!= NULL
)
5364 new_st
.op
= EXEC_NOP
;
5369 case ST_IMPLIED_ENDDO
:
5370 /* If the do-stmt of this DO construct has a do-construct-name,
5371 the corresponding end-do must be an end-do-stmt (with a matching
5372 name, but in that case we must have seen ST_ENDDO first).
5373 We only complain about this in pedantic mode. */
5374 if (gfc_current_block () != NULL
)
5375 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
5376 &gfc_current_block()->declared_at
);
5381 unexpected_statement (st
);
5386 accept_statement (st
);
5390 /* Parse the statements of OpenMP do/parallel do. */
5392 static gfc_statement
5393 parse_omp_do (gfc_statement omp_st
)
5399 accept_statement (omp_st
);
5401 cp
= gfc_state_stack
->tail
;
5402 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5403 np
= new_level (cp
);
5409 st
= next_statement ();
5412 else if (st
== ST_DO
)
5415 unexpected_statement (st
);
5419 if (gfc_statement_label
!= NULL
5420 && gfc_state_stack
->previous
!= NULL
5421 && gfc_state_stack
->previous
->state
== COMP_DO
5422 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
5430 there should be no !$OMP END DO. */
5432 return ST_IMPLIED_ENDDO
;
5435 check_do_closure ();
5438 st
= next_statement ();
5439 gfc_statement omp_end_st
= ST_OMP_END_DO
;
5442 case ST_OMP_DISTRIBUTE
: omp_end_st
= ST_OMP_END_DISTRIBUTE
; break;
5443 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5444 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
5446 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5447 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
5449 case ST_OMP_DISTRIBUTE_SIMD
:
5450 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
5452 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
5453 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
5454 case ST_OMP_LOOP
: omp_end_st
= ST_OMP_END_LOOP
; break;
5455 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
5456 case ST_OMP_PARALLEL_DO_SIMD
:
5457 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
5459 case ST_OMP_PARALLEL_LOOP
:
5460 omp_end_st
= ST_OMP_END_PARALLEL_LOOP
;
5462 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
5463 case ST_OMP_TARGET_PARALLEL_DO
:
5464 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO
;
5466 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
5467 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO_SIMD
;
5469 case ST_OMP_TARGET_PARALLEL_LOOP
:
5470 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_LOOP
;
5472 case ST_OMP_TARGET_SIMD
: omp_end_st
= ST_OMP_END_TARGET_SIMD
; break;
5473 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5474 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
5476 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5477 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5479 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5480 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5482 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5483 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
5485 case ST_OMP_TARGET_TEAMS_LOOP
:
5486 omp_end_st
= ST_OMP_END_TARGET_TEAMS_LOOP
;
5488 case ST_OMP_TASKLOOP
: omp_end_st
= ST_OMP_END_TASKLOOP
; break;
5489 case ST_OMP_TASKLOOP_SIMD
: omp_end_st
= ST_OMP_END_TASKLOOP_SIMD
; break;
5490 case ST_OMP_MASKED_TASKLOOP
: omp_end_st
= ST_OMP_END_MASKED_TASKLOOP
; break;
5491 case ST_OMP_MASKED_TASKLOOP_SIMD
:
5492 omp_end_st
= ST_OMP_END_MASKED_TASKLOOP_SIMD
;
5494 case ST_OMP_MASTER_TASKLOOP
: omp_end_st
= ST_OMP_END_MASTER_TASKLOOP
; break;
5495 case ST_OMP_MASTER_TASKLOOP_SIMD
:
5496 omp_end_st
= ST_OMP_END_MASTER_TASKLOOP_SIMD
;
5498 case ST_OMP_PARALLEL_MASKED_TASKLOOP
:
5499 omp_end_st
= ST_OMP_END_PARALLEL_MASKED_TASKLOOP
;
5501 case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
5502 omp_end_st
= ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD
;
5504 case ST_OMP_PARALLEL_MASTER_TASKLOOP
:
5505 omp_end_st
= ST_OMP_END_PARALLEL_MASTER_TASKLOOP
;
5507 case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
5508 omp_end_st
= ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD
;
5510 case ST_OMP_TEAMS_DISTRIBUTE
:
5511 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
5513 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5514 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5516 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5517 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5519 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5520 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
5522 case ST_OMP_TEAMS_LOOP
:
5523 omp_end_st
= ST_OMP_END_TEAMS_LOOP
;
5525 default: gcc_unreachable ();
5527 if (st
== omp_end_st
)
5529 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
5531 if (cp
->ext
.omp_clauses
->nowait
&& new_st
.ext
.omp_bool
)
5532 gfc_error_now ("Duplicated NOWAIT clause on %s and %s at %C",
5533 gfc_ascii_statement (omp_st
),
5534 gfc_ascii_statement (omp_end_st
));
5535 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
5538 gcc_assert (new_st
.op
== EXEC_NOP
);
5539 gfc_clear_new_st ();
5540 gfc_commit_symbols ();
5541 gfc_warning_check ();
5542 st
= next_statement ();
5548 /* Parse the statements of OpenMP atomic directive. */
5550 static gfc_statement
5551 parse_omp_oacc_atomic (bool omp_p
)
5553 gfc_statement st
, st_atomic
, st_end_atomic
;
5560 st_atomic
= ST_OMP_ATOMIC
;
5561 st_end_atomic
= ST_OMP_END_ATOMIC
;
5565 st_atomic
= ST_OACC_ATOMIC
;
5566 st_end_atomic
= ST_OACC_END_ATOMIC
;
5568 accept_statement (st_atomic
);
5570 cp
= gfc_state_stack
->tail
;
5571 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5572 np
= new_level (cp
);
5575 np
->ext
.omp_clauses
= cp
->ext
.omp_clauses
;
5576 cp
->ext
.omp_clauses
= NULL
;
5577 count
= 1 + np
->ext
.omp_clauses
->capture
;
5581 st
= next_statement ();
5584 else if (np
->ext
.omp_clauses
->compare
5585 && (st
== ST_SIMPLE_IF
|| st
== ST_IF_BLOCK
))
5588 if (st
== ST_IF_BLOCK
)
5591 /* With else (or elseif). */
5592 if (gfc_state_stack
->tail
->block
->block
)
5595 accept_statement (st
);
5597 else if (st
== ST_ASSIGNMENT
5598 && (!np
->ext
.omp_clauses
->compare
5599 || np
->ext
.omp_clauses
->capture
))
5601 accept_statement (st
);
5605 unexpected_statement (st
);
5610 st
= next_statement ();
5611 if (st
== st_end_atomic
)
5613 gfc_clear_new_st ();
5614 gfc_commit_symbols ();
5615 gfc_warning_check ();
5616 st
= next_statement ();
5622 /* Parse the statements of an OpenACC structured block. */
5625 parse_oacc_structured_block (gfc_statement acc_st
)
5627 gfc_statement st
, acc_end_st
;
5629 gfc_state_data s
, *sd
;
5631 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
5632 if (sd
->state
== COMP_CRITICAL
)
5633 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5635 accept_statement (acc_st
);
5637 cp
= gfc_state_stack
->tail
;
5638 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5639 np
= new_level (cp
);
5644 case ST_OACC_PARALLEL
:
5645 acc_end_st
= ST_OACC_END_PARALLEL
;
5647 case ST_OACC_KERNELS
:
5648 acc_end_st
= ST_OACC_END_KERNELS
;
5650 case ST_OACC_SERIAL
:
5651 acc_end_st
= ST_OACC_END_SERIAL
;
5654 acc_end_st
= ST_OACC_END_DATA
;
5656 case ST_OACC_HOST_DATA
:
5657 acc_end_st
= ST_OACC_END_HOST_DATA
;
5665 st
= parse_executable (ST_NONE
);
5668 else if (st
!= acc_end_st
)
5670 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
5671 reject_statement ();
5674 while (st
!= acc_end_st
);
5676 gcc_assert (new_st
.op
== EXEC_NOP
);
5678 gfc_clear_new_st ();
5679 gfc_commit_symbols ();
5680 gfc_warning_check ();
5684 /* Parse the statements of OpenACC 'loop', or combined compute 'loop'. */
5686 static gfc_statement
5687 parse_oacc_loop (gfc_statement acc_st
)
5691 gfc_state_data s
, *sd
;
5693 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
5694 if (sd
->state
== COMP_CRITICAL
)
5695 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5697 accept_statement (acc_st
);
5699 cp
= gfc_state_stack
->tail
;
5700 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5701 np
= new_level (cp
);
5707 st
= next_statement ();
5710 else if (st
== ST_DO
)
5714 gfc_error ("Expected DO loop at %C");
5715 reject_statement ();
5720 if (gfc_statement_label
!= NULL
5721 && gfc_state_stack
->previous
!= NULL
5722 && gfc_state_stack
->previous
->state
== COMP_DO
5723 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
5726 return ST_IMPLIED_ENDDO
;
5729 check_do_closure ();
5732 st
= next_statement ();
5733 if (st
== ST_OACC_END_LOOP
)
5734 gfc_warning (0, "Redundant !$ACC END LOOP at %C");
5735 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
5736 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
5737 (acc_st
== ST_OACC_SERIAL_LOOP
&& st
== ST_OACC_END_SERIAL_LOOP
) ||
5738 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
5740 gcc_assert (new_st
.op
== EXEC_NOP
);
5741 gfc_clear_new_st ();
5742 gfc_commit_symbols ();
5743 gfc_warning_check ();
5744 st
= next_statement ();
5750 /* Parse an OpenMP allocate block, including optional ALLOCATORS
5753 static gfc_statement
5754 parse_openmp_allocate_block (gfc_statement omp_st
)
5759 bool empty_list
= false;
5760 locus empty_list_loc
;
5761 gfc_omp_namelist
*n_first
= new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
];
5763 if (omp_st
== ST_OMP_ALLOCATE_EXEC
5764 && new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->sym
== NULL
)
5767 empty_list_loc
= new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->where
;
5770 accept_statement (omp_st
);
5772 cp
= gfc_state_stack
->tail
;
5773 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5774 np
= new_level (cp
);
5778 st
= next_statement ();
5779 while (omp_st
== ST_OMP_ALLOCATE_EXEC
&& st
== ST_OMP_ALLOCATE_EXEC
)
5781 if (empty_list
&& !new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->sym
)
5783 locus
*loc
= &new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->where
;
5784 gfc_error_now ("%s statements at %L and %L have both no list item but"
5785 " only one may", gfc_ascii_statement (st
),
5786 &empty_list_loc
, loc
);
5789 if (!new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->sym
)
5792 empty_list_loc
= new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->where
;
5794 for ( ; n_first
->next
; n_first
= n_first
->next
)
5796 n_first
->next
= new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
];
5797 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
] = NULL
;
5798 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
5800 accept_statement (ST_NONE
);
5801 st
= next_statement ();
5803 if (st
!= ST_ALLOCATE
&& omp_st
== ST_OMP_ALLOCATE_EXEC
)
5804 gfc_error_now ("Unexpected %s at %C; expected ALLOCATE or %s statement",
5805 gfc_ascii_statement (st
), gfc_ascii_statement (omp_st
));
5806 else if (st
!= ST_ALLOCATE
)
5807 gfc_error_now ("Unexpected %s at %C; expected ALLOCATE statement after %s",
5808 gfc_ascii_statement (st
), gfc_ascii_statement (omp_st
));
5809 accept_statement (st
);
5811 st
= next_statement ();
5812 if (omp_st
== ST_OMP_ALLOCATORS
&& st
== ST_OMP_END_ALLOCATORS
)
5814 accept_statement (st
);
5815 st
= next_statement ();
5821 /* Parse the statements of an OpenMP structured block. */
5823 static gfc_statement
5824 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
5826 gfc_statement st
, omp_end_st
, first_st
;
5828 gfc_state_data s
, s2
;
5830 accept_statement (omp_st
);
5832 cp
= gfc_state_stack
->tail
;
5833 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5834 np
= new_level (cp
);
5841 omp_end_st
= ST_OMP_END_ASSUME
;
5843 case ST_OMP_PARALLEL
:
5844 omp_end_st
= ST_OMP_END_PARALLEL
;
5846 case ST_OMP_PARALLEL_MASKED
:
5847 omp_end_st
= ST_OMP_END_PARALLEL_MASKED
;
5849 case ST_OMP_PARALLEL_MASTER
:
5850 omp_end_st
= ST_OMP_END_PARALLEL_MASTER
;
5852 case ST_OMP_PARALLEL_SECTIONS
:
5853 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
5856 omp_end_st
= ST_OMP_END_SCOPE
;
5858 case ST_OMP_SECTIONS
:
5859 omp_end_st
= ST_OMP_END_SECTIONS
;
5861 case ST_OMP_ORDERED
:
5862 omp_end_st
= ST_OMP_END_ORDERED
;
5864 case ST_OMP_CRITICAL
:
5865 omp_end_st
= ST_OMP_END_CRITICAL
;
5868 omp_end_st
= ST_OMP_END_MASKED
;
5871 omp_end_st
= ST_OMP_END_MASTER
;
5874 omp_end_st
= ST_OMP_END_SINGLE
;
5877 omp_end_st
= ST_OMP_END_TARGET
;
5879 case ST_OMP_TARGET_DATA
:
5880 omp_end_st
= ST_OMP_END_TARGET_DATA
;
5882 case ST_OMP_TARGET_PARALLEL
:
5883 omp_end_st
= ST_OMP_END_TARGET_PARALLEL
;
5885 case ST_OMP_TARGET_TEAMS
:
5886 omp_end_st
= ST_OMP_END_TARGET_TEAMS
;
5889 omp_end_st
= ST_OMP_END_TASK
;
5891 case ST_OMP_TASKGROUP
:
5892 omp_end_st
= ST_OMP_END_TASKGROUP
;
5895 omp_end_st
= ST_OMP_END_TEAMS
;
5897 case ST_OMP_TEAMS_DISTRIBUTE
:
5898 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
5900 case ST_OMP_DISTRIBUTE
:
5901 omp_end_st
= ST_OMP_END_DISTRIBUTE
;
5903 case ST_OMP_WORKSHARE
:
5904 omp_end_st
= ST_OMP_END_WORKSHARE
;
5906 case ST_OMP_PARALLEL_WORKSHARE
:
5907 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
5913 bool block_construct
= false;
5914 gfc_namespace
*my_ns
= NULL
;
5915 gfc_namespace
*my_parent
= NULL
;
5917 first_st
= st
= next_statement ();
5921 /* Adjust state to a strictly-structured block, now that we found that
5922 the body starts with a BLOCK construct. */
5923 s
.state
= COMP_OMP_STRICTLY_STRUCTURED_BLOCK
;
5925 block_construct
= true;
5926 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
5928 my_ns
= gfc_build_block_ns (gfc_current_ns
);
5929 new_st
.op
= EXEC_BLOCK
;
5930 new_st
.ext
.block
.ns
= my_ns
;
5931 new_st
.ext
.block
.assoc
= NULL
;
5932 accept_statement (ST_BLOCK
);
5934 push_state (&s2
, COMP_BLOCK
, my_ns
->proc_name
);
5935 gfc_current_ns
= my_ns
;
5936 my_parent
= my_ns
->parent
;
5937 if (omp_st
== ST_OMP_SECTIONS
5938 || omp_st
== ST_OMP_PARALLEL_SECTIONS
)
5940 np
= new_level (cp
);
5944 first_st
= next_statement ();
5945 st
= parse_spec (first_st
);
5948 if (omp_end_st
== ST_OMP_END_TARGET
)
5952 case ST_OMP_TEAMS_DISTRIBUTE
:
5953 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5954 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5955 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5956 case ST_OMP_TEAMS_LOOP
:
5958 gfc_state_data
*stk
= gfc_state_stack
->previous
;
5959 if (stk
->state
== COMP_OMP_STRICTLY_STRUCTURED_BLOCK
)
5960 stk
= stk
->previous
;
5961 stk
->tail
->ext
.omp_clauses
->target_first_st_is_teams
= true;
5970 if (workshare_stmts_only
)
5972 /* Inside of !$omp workshare, only
5975 where statements and constructs
5976 forall statements and constructs
5980 are allowed. For !$omp critical these
5981 restrictions apply recursively. */
5994 accept_statement (st
);
5997 case ST_WHERE_BLOCK
:
5998 parse_where_block ();
6001 case ST_FORALL_BLOCK
:
6002 parse_forall_block ();
6005 case ST_OMP_ALLOCATE_EXEC
:
6006 case ST_OMP_ALLOCATORS
:
6007 st
= parse_openmp_allocate_block (st
);
6011 case ST_OMP_PARALLEL
:
6012 case ST_OMP_PARALLEL_MASKED
:
6013 case ST_OMP_PARALLEL_MASTER
:
6014 case ST_OMP_PARALLEL_SECTIONS
:
6015 st
= parse_omp_structured_block (st
, false);
6018 case ST_OMP_PARALLEL_WORKSHARE
:
6019 case ST_OMP_CRITICAL
:
6020 st
= parse_omp_structured_block (st
, true);
6023 case ST_OMP_PARALLEL_DO
:
6024 case ST_OMP_PARALLEL_DO_SIMD
:
6025 st
= parse_omp_do (st
);
6029 st
= parse_omp_oacc_atomic (true);
6040 st
= next_statement ();
6044 st
= parse_executable (st
);
6047 else if (st
== ST_OMP_SECTION
6048 && (omp_st
== ST_OMP_SECTIONS
6049 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
6051 np
= new_level (np
);
6054 st
= next_statement ();
6056 else if (block_construct
&& st
== ST_END_BLOCK
)
6058 accept_statement (st
);
6059 gfc_current_ns
->code
= gfc_state_stack
->head
;
6060 gfc_current_ns
= my_parent
;
6061 pop_state (); /* Inner BLOCK */
6062 pop_state (); /* Outer COMP_OMP_STRICTLY_STRUCTURED_BLOCK */
6064 st
= next_statement ();
6065 if (st
== omp_end_st
)
6067 accept_statement (st
);
6068 st
= next_statement ();
6072 else if (st
!= omp_end_st
|| block_construct
)
6074 unexpected_statement (st
);
6075 st
= next_statement ();
6078 while (st
!= omp_end_st
);
6082 case EXEC_OMP_END_NOWAIT
:
6083 if (cp
->ext
.omp_clauses
->nowait
&& new_st
.ext
.omp_bool
)
6084 gfc_error_now ("Duplicated NOWAIT clause on %s and %s at %C",
6085 gfc_ascii_statement (omp_st
),
6086 gfc_ascii_statement (omp_end_st
));
6087 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
6089 case EXEC_OMP_END_CRITICAL
:
6090 if (((cp
->ext
.omp_clauses
->critical_name
== NULL
)
6091 ^ (new_st
.ext
.omp_name
== NULL
))
6092 || (new_st
.ext
.omp_name
!= NULL
6093 && strcmp (cp
->ext
.omp_clauses
->critical_name
,
6094 new_st
.ext
.omp_name
) != 0))
6095 gfc_error ("Name after !$omp critical and !$omp end critical does "
6097 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
6098 new_st
.ext
.omp_name
= NULL
;
6100 case EXEC_OMP_END_SINGLE
:
6101 if (cp
->ext
.omp_clauses
->nowait
&& new_st
.ext
.omp_clauses
->nowait
)
6102 gfc_error_now ("Duplicated NOWAIT clause on %s and %s at %C",
6103 gfc_ascii_statement (omp_st
),
6104 gfc_ascii_statement (omp_end_st
));
6105 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_clauses
->nowait
;
6106 if (cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
])
6108 gfc_omp_namelist
*nl
;
6109 for (nl
= cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
6110 nl
->next
; nl
= nl
->next
)
6112 nl
->next
= new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
6115 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
6116 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
6117 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
6118 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
6126 gfc_clear_new_st ();
6127 gfc_commit_symbols ();
6128 gfc_warning_check ();
6130 st
= next_statement ();
6135 /* Accept a series of executable statements. We return the first
6136 statement that doesn't fit to the caller. Any block statements are
6137 passed on to the correct handler, which usually passes the buck
6140 static gfc_statement
6141 parse_executable (gfc_statement st
)
6144 in_exec_part
= true;
6147 st
= next_statement ();
6151 close_flag
= check_do_closure ();
6156 case ST_END_PROGRAM
:
6159 case ST_END_FUNCTION
:
6164 case ST_END_SUBROUTINE
:
6169 case ST_SELECT_CASE
:
6170 gfc_error ("%s statement at %C cannot terminate a non-block "
6171 "DO loop", gfc_ascii_statement (st
));
6184 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
6185 "first executable statement");
6191 accept_statement (st
);
6192 if (close_flag
== 1)
6193 return ST_IMPLIED_ENDDO
;
6197 parse_block_construct ();
6208 case ST_SELECT_CASE
:
6209 parse_select_block ();
6212 case ST_SELECT_TYPE
:
6213 parse_select_type_block ();
6216 case ST_SELECT_RANK
:
6217 parse_select_rank_block ();
6222 if (check_do_closure () == 1)
6223 return ST_IMPLIED_ENDDO
;
6227 parse_critical_block ();
6230 case ST_WHERE_BLOCK
:
6231 parse_where_block ();
6234 case ST_FORALL_BLOCK
:
6235 parse_forall_block ();
6238 case ST_OACC_PARALLEL_LOOP
:
6239 case ST_OACC_KERNELS_LOOP
:
6240 case ST_OACC_SERIAL_LOOP
:
6242 st
= parse_oacc_loop (st
);
6243 if (st
== ST_IMPLIED_ENDDO
)
6247 case ST_OACC_PARALLEL
:
6248 case ST_OACC_KERNELS
:
6249 case ST_OACC_SERIAL
:
6251 case ST_OACC_HOST_DATA
:
6252 parse_oacc_structured_block (st
);
6255 case ST_OMP_ALLOCATE_EXEC
:
6256 case ST_OMP_ALLOCATORS
:
6257 st
= parse_openmp_allocate_block (st
);
6261 case ST_OMP_PARALLEL
:
6262 case ST_OMP_PARALLEL_MASKED
:
6263 case ST_OMP_PARALLEL_MASTER
:
6264 case ST_OMP_PARALLEL_SECTIONS
:
6265 case ST_OMP_ORDERED
:
6266 case ST_OMP_CRITICAL
:
6270 case ST_OMP_SECTIONS
:
6273 case ST_OMP_TARGET_DATA
:
6274 case ST_OMP_TARGET_PARALLEL
:
6275 case ST_OMP_TARGET_TEAMS
:
6278 case ST_OMP_TASKGROUP
:
6279 st
= parse_omp_structured_block (st
, false);
6282 case ST_OMP_WORKSHARE
:
6283 case ST_OMP_PARALLEL_WORKSHARE
:
6284 st
= parse_omp_structured_block (st
, true);
6287 case ST_OMP_DISTRIBUTE
:
6288 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
6289 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
6290 case ST_OMP_DISTRIBUTE_SIMD
:
6292 case ST_OMP_DO_SIMD
:
6294 case ST_OMP_PARALLEL_DO
:
6295 case ST_OMP_PARALLEL_DO_SIMD
:
6296 case ST_OMP_PARALLEL_LOOP
:
6297 case ST_OMP_PARALLEL_MASKED_TASKLOOP
:
6298 case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
6299 case ST_OMP_PARALLEL_MASTER_TASKLOOP
:
6300 case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
6301 case ST_OMP_MASKED_TASKLOOP
:
6302 case ST_OMP_MASKED_TASKLOOP_SIMD
:
6303 case ST_OMP_MASTER_TASKLOOP
:
6304 case ST_OMP_MASTER_TASKLOOP_SIMD
:
6306 case ST_OMP_TARGET_PARALLEL_DO
:
6307 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
6308 case ST_OMP_TARGET_PARALLEL_LOOP
:
6309 case ST_OMP_TARGET_SIMD
:
6310 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
6311 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
6312 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
6313 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
6314 case ST_OMP_TARGET_TEAMS_LOOP
:
6315 case ST_OMP_TASKLOOP
:
6316 case ST_OMP_TASKLOOP_SIMD
:
6317 case ST_OMP_TEAMS_DISTRIBUTE
:
6318 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
6319 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
6320 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
6321 case ST_OMP_TEAMS_LOOP
:
6322 st
= parse_omp_do (st
);
6323 if (st
== ST_IMPLIED_ENDDO
)
6327 case ST_OACC_ATOMIC
:
6328 st
= parse_omp_oacc_atomic (false);
6332 st
= parse_omp_oacc_atomic (true);
6339 if (directive_unroll
!= -1)
6340 gfc_error ("%<GCC unroll%> directive not at the start of a loop at %C");
6342 if (directive_ivdep
)
6343 gfc_error ("%<GCC ivdep%> directive not at the start of a loop at %C");
6345 if (directive_vector
)
6346 gfc_error ("%<GCC vector%> directive not at the start of a loop at %C");
6348 if (directive_novector
)
6349 gfc_error ("%<GCC novector%> "
6350 "directive not at the start of a loop at %C");
6352 st
= next_statement ();
6357 /* Fix the symbols for sibling functions. These are incorrectly added to
6358 the child namespace as the parser didn't know about this procedure. */
6361 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
6365 gfc_symbol
*old_sym
;
6367 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
6369 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
6371 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
6372 goto fixup_contained
;
6374 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
6375 && sym
->attr
.generic
&& sym
->attr
.function
)
6376 ||(sym
->attr
.flavor
== FL_DERIVED
6377 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
6378 goto fixup_contained
;
6380 old_sym
= st
->n
.sym
;
6381 if (old_sym
->ns
== ns
6382 && !old_sym
->attr
.contained
6384 /* By 14.6.1.3, host association should be excluded
6385 for the following. */
6386 && !(old_sym
->attr
.external
6387 || (old_sym
->ts
.type
!= BT_UNKNOWN
6388 && !old_sym
->attr
.implicit_type
)
6389 || old_sym
->attr
.flavor
== FL_PARAMETER
6390 || old_sym
->attr
.use_assoc
6391 || old_sym
->attr
.in_common
6392 || old_sym
->attr
.in_equivalence
6393 || old_sym
->attr
.data
6394 || old_sym
->attr
.dummy
6395 || old_sym
->attr
.result
6396 || old_sym
->attr
.dimension
6397 || old_sym
->attr
.allocatable
6398 || old_sym
->attr
.intrinsic
6399 || old_sym
->attr
.generic
6400 || old_sym
->attr
.flavor
== FL_NAMELIST
6401 || old_sym
->attr
.flavor
== FL_LABEL
6402 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
6404 /* Replace it with the symbol from the parent namespace. */
6408 gfc_release_symbol (old_sym
);
6412 /* Do the same for any contained procedures. */
6413 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
6418 parse_contained (int module
)
6420 gfc_namespace
*ns
, *parent_ns
, *tmp
;
6421 gfc_state_data s1
, s2
;
6426 int contains_statements
= 0;
6429 push_state (&s1
, COMP_CONTAINS
, NULL
);
6430 parent_ns
= gfc_current_ns
;
6434 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
6436 gfc_current_ns
->sibling
= parent_ns
->contained
;
6437 parent_ns
->contained
= gfc_current_ns
;
6440 /* Process the next available statement. We come here if we got an error
6441 and rejected the last statement. */
6442 old_loc
= gfc_current_locus
;
6443 st
= next_statement ();
6452 contains_statements
= 1;
6453 accept_statement (st
);
6456 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
6459 /* For internal procedures, create/update the symbol in the
6460 parent namespace. */
6464 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
6465 gfc_error ("Contained procedure %qs at %C is already "
6466 "ambiguous", gfc_new_block
->name
);
6469 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
6471 &gfc_new_block
->declared_at
))
6473 if (st
== ST_FUNCTION
)
6474 gfc_add_function (&sym
->attr
, sym
->name
,
6475 &gfc_new_block
->declared_at
);
6477 gfc_add_subroutine (&sym
->attr
, sym
->name
,
6478 &gfc_new_block
->declared_at
);
6482 gfc_commit_symbols ();
6485 sym
= gfc_new_block
;
6487 /* Mark this as a contained function, so it isn't replaced
6488 by other module functions. */
6489 sym
->attr
.contained
= 1;
6491 /* Set implicit_pure so that it can be reset if any of the
6492 tests for purity fail. This is used for some optimisation
6493 during translation. */
6494 if (!sym
->attr
.pure
)
6495 sym
->attr
.implicit_pure
= 1;
6497 parse_progunit (ST_NONE
);
6499 /* Fix up any sibling functions that refer to this one. */
6500 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
6501 /* Or refer to any of its alternate entry points. */
6502 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
6503 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
6505 gfc_current_ns
->code
= s2
.head
;
6506 gfc_current_ns
= parent_ns
;
6511 /* These statements are associated with the end of the host unit. */
6512 case ST_END_FUNCTION
:
6514 case ST_END_SUBMODULE
:
6515 case ST_END_PROGRAM
:
6516 case ST_END_SUBROUTINE
:
6517 accept_statement (st
);
6518 gfc_current_ns
->code
= s1
.head
;
6522 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
6523 gfc_ascii_statement (st
));
6524 reject_statement ();
6530 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
6531 && st
!= ST_END_MODULE
&& st
!= ST_END_SUBMODULE
6532 && st
!= ST_END_PROGRAM
);
6534 /* The first namespace in the list is guaranteed to not have
6535 anything (worthwhile) in it. */
6536 tmp
= gfc_current_ns
;
6537 gfc_current_ns
= parent_ns
;
6538 if (seen_error
&& tmp
->refs
> 1)
6539 gfc_free_namespace (tmp
);
6541 ns
= gfc_current_ns
->contained
;
6542 gfc_current_ns
->contained
= ns
->sibling
;
6543 gfc_free_namespace (ns
);
6546 if (!contains_statements
)
6547 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
6548 "FUNCTION or SUBROUTINE statement at %L", &old_loc
);
6552 /* The result variable in a MODULE PROCEDURE needs to be created and
6553 its characteristics copied from the interface since it is neither
6554 declared in the procedure declaration nor in the specification
6558 get_modproc_result (void)
6561 if (gfc_state_stack
->previous
6562 && gfc_state_stack
->previous
->state
== COMP_CONTAINS
6563 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
6565 proc
= gfc_current_ns
->proc_name
? gfc_current_ns
->proc_name
: NULL
;
6567 && proc
->attr
.function
6569 && proc
->tlink
->result
6570 && proc
->tlink
->result
!= proc
->tlink
)
6572 gfc_copy_dummy_sym (&proc
->result
, proc
->tlink
->result
, 1);
6573 gfc_set_sym_referenced (proc
->result
);
6574 proc
->result
->attr
.if_source
= IFSRC_DECL
;
6575 gfc_commit_symbol (proc
->result
);
6581 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
6584 parse_progunit (gfc_statement st
)
6589 gfc_adjust_builtins ();
6592 && gfc_new_block
->abr_modproc_decl
6593 && gfc_new_block
->attr
.function
)
6594 get_modproc_result ();
6596 st
= parse_spec (st
);
6603 /* This is not allowed within BLOCK! */
6604 if (gfc_current_state () != COMP_BLOCK
)
6609 accept_statement (st
);
6616 if (gfc_current_state () == COMP_FUNCTION
)
6617 gfc_check_function_type (gfc_current_ns
);
6622 st
= parse_executable (st
);
6630 /* This is not allowed within BLOCK! */
6631 if (gfc_current_state () != COMP_BLOCK
)
6636 accept_statement (st
);
6643 unexpected_statement (st
);
6644 reject_statement ();
6645 st
= next_statement ();
6651 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
6652 if (p
->state
== COMP_CONTAINS
)
6655 if (gfc_find_state (COMP_MODULE
) == true
6656 || gfc_find_state (COMP_SUBMODULE
) == true)
6661 gfc_error ("CONTAINS statement at %C is already in a contained "
6663 reject_statement ();
6664 st
= next_statement ();
6668 parse_contained (0);
6671 gfc_current_ns
->code
= gfc_state_stack
->head
;
6675 /* Come here to complain about a global symbol already in use as
6679 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
6684 where
= &gfc_current_locus
;
6694 case GSYM_SUBROUTINE
:
6695 name
= "SUBROUTINE";
6700 case GSYM_BLOCK_DATA
:
6701 name
= "BLOCK DATA";
6712 if (sym
->binding_label
)
6713 gfc_error ("Global binding name %qs at %L is already being used "
6714 "as a %s at %L", sym
->binding_label
, where
, name
,
6717 gfc_error ("Global name %qs at %L is already being used as "
6718 "a %s at %L", sym
->name
, where
, name
, &sym
->where
);
6722 if (sym
->binding_label
)
6723 gfc_error ("Global binding name %qs at %L is already being used "
6724 "at %L", sym
->binding_label
, where
, &sym
->where
);
6726 gfc_error ("Global name %qs at %L is already being used at %L",
6727 sym
->name
, where
, &sym
->where
);
6732 /* Parse a block data program unit. */
6735 parse_block_data (void)
6738 static locus blank_locus
;
6739 static int blank_block
=0;
6742 gfc_current_ns
->proc_name
= gfc_new_block
;
6743 gfc_current_ns
->is_block_data
= 1;
6745 if (gfc_new_block
== NULL
)
6748 gfc_error ("Blank BLOCK DATA at %C conflicts with "
6749 "prior BLOCK DATA at %L", &blank_locus
);
6753 blank_locus
= gfc_current_locus
;
6758 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6760 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
6761 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6764 s
->type
= GSYM_BLOCK_DATA
;
6765 s
->where
= gfc_new_block
->declared_at
;
6770 st
= parse_spec (ST_NONE
);
6772 while (st
!= ST_END_BLOCK_DATA
)
6774 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
6775 gfc_ascii_statement (st
));
6776 reject_statement ();
6777 st
= next_statement ();
6782 /* Following the association of the ancestor (sub)module symbols, they
6783 must be set host rather than use associated and all must be public.
6784 They are flagged up by 'used_in_submodule' so that they can be set
6785 DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
6786 linker chokes on multiple symbol definitions. */
6789 set_syms_host_assoc (gfc_symbol
*sym
)
6792 const char dot
[2] = ".";
6793 /* Symbols take the form module.submodule_ or module.name_. */
6794 char parent1
[2 * GFC_MAX_SYMBOL_LEN
+ 2];
6795 char parent2
[2 * GFC_MAX_SYMBOL_LEN
+ 2];
6800 if (sym
->attr
.module_procedure
)
6801 sym
->attr
.external
= 0;
6803 sym
->attr
.use_assoc
= 0;
6804 sym
->attr
.host_assoc
= 1;
6805 sym
->attr
.used_in_submodule
=1;
6807 if (sym
->attr
.flavor
== FL_DERIVED
)
6809 /* Derived types with PRIVATE components that are declared in
6810 modules other than the parent module must not be changed to be
6811 PUBLIC. The 'use-assoc' attribute must be reset so that the
6812 test in symbol.cc(gfc_find_component) works correctly. This is
6813 not necessary for PRIVATE symbols since they are not read from
6815 memset(parent1
, '\0', sizeof(parent1
));
6816 memset(parent2
, '\0', sizeof(parent2
));
6817 strcpy (parent1
, gfc_new_block
->name
);
6818 strcpy (parent2
, sym
->module
);
6819 if (strcmp (strtok (parent1
, dot
), strtok (parent2
, dot
)) == 0)
6821 for (c
= sym
->components
; c
; c
= c
->next
)
6822 c
->attr
.access
= ACCESS_PUBLIC
;
6826 sym
->attr
.use_assoc
= 1;
6827 sym
->attr
.host_assoc
= 0;
6832 /* Parse a module subprogram. */
6840 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6841 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
6842 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6845 s
->type
= GSYM_MODULE
;
6846 s
->where
= gfc_new_block
->declared_at
;
6850 /* Something is nulling the module_list after this point. This is good
6851 since it allows us to 'USE' the parent modules that the submodule
6852 inherits and to set (most) of the symbols as host associated. */
6853 if (gfc_current_state () == COMP_SUBMODULE
)
6856 gfc_traverse_ns (gfc_current_ns
, set_syms_host_assoc
);
6859 st
= parse_spec (ST_NONE
);
6868 parse_contained (1);
6872 case ST_END_SUBMODULE
:
6873 accept_statement (st
);
6877 gfc_error ("Unexpected %s statement in MODULE at %C",
6878 gfc_ascii_statement (st
));
6879 reject_statement ();
6880 st
= next_statement ();
6883 s
->ns
= gfc_current_ns
;
6887 /* Add a procedure name to the global symbol table. */
6890 add_global_procedure (bool sub
)
6894 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6895 name is a global identifier. */
6896 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
6898 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6901 || (s
->type
!= GSYM_UNKNOWN
6902 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
6904 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6905 /* Silence follow-up errors. */
6906 gfc_new_block
->binding_label
= NULL
;
6910 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6911 s
->sym_name
= gfc_new_block
->name
;
6912 s
->where
= gfc_new_block
->declared_at
;
6914 s
->ns
= gfc_current_ns
;
6918 /* Don't add the symbol multiple times. */
6919 if (gfc_new_block
->binding_label
6920 && (!gfc_notification_std (GFC_STD_F2008
)
6921 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
6923 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
, true);
6926 || (s
->type
!= GSYM_UNKNOWN
6927 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
6929 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6930 /* Silence follow-up errors. */
6931 gfc_new_block
->binding_label
= NULL
;
6935 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6936 s
->sym_name
= gfc_new_block
->name
;
6937 s
->binding_label
= gfc_new_block
->binding_label
;
6938 s
->where
= gfc_new_block
->declared_at
;
6940 s
->ns
= gfc_current_ns
;
6946 /* Add a program to the global symbol table. */
6949 add_global_program (void)
6953 if (gfc_new_block
== NULL
)
6955 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6957 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
6958 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6961 s
->type
= GSYM_PROGRAM
;
6962 s
->where
= gfc_new_block
->declared_at
;
6964 s
->ns
= gfc_current_ns
;
6969 /* Resolve all the program units. */
6971 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
6973 gfc_derived_types
= NULL
;
6974 gfc_current_ns
= gfc_global_ns_list
;
6975 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
6977 if (gfc_current_ns
->proc_name
6978 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
6979 continue; /* Already resolved. */
6981 if (gfc_current_ns
->proc_name
)
6982 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
6983 gfc_resolve (gfc_current_ns
);
6984 gfc_current_ns
->derived_types
= gfc_derived_types
;
6985 gfc_derived_types
= NULL
;
6991 clean_up_modules (gfc_gsymbol
*&gsym
)
6996 clean_up_modules (gsym
->left
);
6997 clean_up_modules (gsym
->right
);
6999 if (gsym
->type
!= GSYM_MODULE
)
7004 gfc_current_ns
= gsym
->ns
;
7005 gfc_derived_types
= gfc_current_ns
->derived_types
;
7014 /* Translate all the program units. This could be in a different order
7015 to resolution if there are forward references in the file. */
7017 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
7021 gfc_current_ns
= gfc_global_ns_list
;
7022 gfc_get_errors (NULL
, &errors
);
7024 /* We first translate all modules to make sure that later parts
7025 of the program can use the decl. Then we translate the nonmodules. */
7027 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
7029 if (!gfc_current_ns
->proc_name
7030 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7033 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
7034 gfc_derived_types
= gfc_current_ns
->derived_types
;
7035 gfc_generate_module_code (gfc_current_ns
);
7036 gfc_current_ns
->translated
= 1;
7039 gfc_current_ns
= gfc_global_ns_list
;
7040 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
7042 if (gfc_current_ns
->proc_name
7043 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
7046 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
7047 gfc_derived_types
= gfc_current_ns
->derived_types
;
7048 gfc_generate_code (gfc_current_ns
);
7049 gfc_current_ns
->translated
= 1;
7052 /* Clean up all the namespaces after translation. */
7053 gfc_current_ns
= gfc_global_ns_list
;
7054 for (;gfc_current_ns
;)
7058 if (gfc_current_ns
->proc_name
7059 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
7061 gfc_current_ns
= gfc_current_ns
->sibling
;
7065 ns
= gfc_current_ns
->sibling
;
7066 gfc_derived_types
= gfc_current_ns
->derived_types
;
7068 gfc_current_ns
= ns
;
7071 clean_up_modules (gfc_gsym_root
);
7075 /* Top level parser. */
7078 gfc_parse_file (void)
7080 int seen_program
, errors_before
, errors
;
7081 gfc_state_data top
, s
;
7084 gfc_namespace
*next
;
7086 gfc_start_source_files ();
7088 top
.state
= COMP_NONE
;
7090 top
.previous
= NULL
;
7091 top
.head
= top
.tail
= NULL
;
7092 top
.do_variable
= NULL
;
7094 gfc_state_stack
= &top
;
7096 gfc_clear_new_st ();
7098 gfc_statement_label
= NULL
;
7100 if (setjmp (eof_buf
))
7101 return false; /* Come here on unexpected EOF */
7103 /* Prepare the global namespace that will contain the
7105 gfc_global_ns_list
= next
= NULL
;
7110 /* Exit early for empty files. */
7114 in_specification_block
= true;
7117 st
= next_statement ();
7126 goto duplicate_main
;
7128 prog_locus
= gfc_current_locus
;
7130 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
7131 main_program_symbol (gfc_current_ns
, gfc_new_block
->name
);
7132 accept_statement (st
);
7133 add_global_program ();
7134 parse_progunit (ST_NONE
);
7138 add_global_procedure (true);
7139 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
7140 accept_statement (st
);
7141 parse_progunit (ST_NONE
);
7145 add_global_procedure (false);
7146 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
7147 accept_statement (st
);
7148 parse_progunit (ST_NONE
);
7152 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
7153 accept_statement (st
);
7154 parse_block_data ();
7158 push_state (&s
, COMP_MODULE
, gfc_new_block
);
7159 accept_statement (st
);
7161 gfc_get_errors (NULL
, &errors_before
);
7166 push_state (&s
, COMP_SUBMODULE
, gfc_new_block
);
7167 accept_statement (st
);
7169 gfc_get_errors (NULL
, &errors_before
);
7173 /* Anything else starts a nameless main program block. */
7176 goto duplicate_main
;
7178 prog_locus
= gfc_current_locus
;
7180 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
7181 main_program_symbol (gfc_current_ns
, "MAIN__");
7182 parse_progunit (st
);
7186 /* Handle the non-program units. */
7187 gfc_current_ns
->code
= s
.head
;
7189 gfc_resolve (gfc_current_ns
);
7191 /* Fix the implicit_pure attribute for those procedures who should
7193 while (gfc_fix_implicit_pure (gfc_current_ns
))
7196 /* Dump the parse tree if requested. */
7197 if (flag_dump_fortran_original
)
7198 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
7200 gfc_get_errors (NULL
, &errors
);
7201 if (s
.state
== COMP_MODULE
|| s
.state
== COMP_SUBMODULE
)
7203 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
7204 gfc_current_ns
->derived_types
= gfc_derived_types
;
7205 gfc_derived_types
= NULL
;
7211 gfc_generate_code (gfc_current_ns
);
7219 /* The main program and non-contained procedures are put
7220 in the global namespace list, so that they can be processed
7221 later and all their interfaces resolved. */
7222 gfc_current_ns
->code
= s
.head
;
7225 for (; next
->sibling
; next
= next
->sibling
)
7227 next
->sibling
= gfc_current_ns
;
7230 gfc_global_ns_list
= gfc_current_ns
;
7232 next
= gfc_current_ns
;
7238 /* Do the resolution. */
7239 resolve_all_program_units (gfc_global_ns_list
);
7241 /* Go through all top-level namespaces and unset the implicit_pure
7242 attribute for any procedures that call something not pure or
7243 implicit_pure. Because the a procedure marked as not implicit_pure
7244 in one sweep may be called by another routine, we repeat this
7245 process until there are no more changes. */
7250 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
7251 gfc_current_ns
= gfc_current_ns
->sibling
)
7253 if (gfc_fix_implicit_pure (gfc_current_ns
))
7259 /* Fixup for external procedures and resolve 'omp requires'. */
7261 bool omp_target_seen
;
7263 omp_target_seen
= false;
7264 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
7265 gfc_current_ns
= gfc_current_ns
->sibling
)
7267 omp_requires
|= gfc_current_ns
->omp_requires
;
7268 omp_target_seen
|= gfc_current_ns
->omp_target_seen
;
7269 gfc_check_externals (gfc_current_ns
);
7271 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
7272 gfc_current_ns
= gfc_current_ns
->sibling
)
7273 gfc_check_omp_requires (gfc_current_ns
, omp_requires
);
7275 /* Populate omp_requires_mask (needed for resolving OpenMP
7276 metadirectives and declare variant). */
7277 switch (omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
7279 case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST
:
7281 = (enum omp_requires
) (omp_requires_mask
| OMP_MEMORY_ORDER_SEQ_CST
);
7283 case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL
:
7285 = (enum omp_requires
) (omp_requires_mask
| OMP_MEMORY_ORDER_ACQ_REL
);
7287 case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE
:
7289 = (enum omp_requires
) (omp_requires_mask
| OMP_MEMORY_ORDER_ACQUIRE
);
7291 case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED
:
7293 = (enum omp_requires
) (omp_requires_mask
| OMP_MEMORY_ORDER_RELAXED
);
7295 case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE
:
7297 = (enum omp_requires
) (omp_requires_mask
| OMP_MEMORY_ORDER_RELEASE
);
7301 if (omp_target_seen
)
7302 omp_requires_mask
= (enum omp_requires
) (omp_requires_mask
7303 | OMP_REQUIRES_TARGET_USED
);
7304 if (omp_requires
& OMP_REQ_REVERSE_OFFLOAD
)
7305 omp_requires_mask
= (enum omp_requires
) (omp_requires_mask
7306 | OMP_REQUIRES_REVERSE_OFFLOAD
);
7307 if (omp_requires
& OMP_REQ_UNIFIED_ADDRESS
)
7308 omp_requires_mask
= (enum omp_requires
) (omp_requires_mask
7309 | OMP_REQUIRES_UNIFIED_ADDRESS
);
7310 if (omp_requires
& OMP_REQ_UNIFIED_SHARED_MEMORY
)
7312 = (enum omp_requires
) (omp_requires_mask
7313 | OMP_REQUIRES_UNIFIED_SHARED_MEMORY
);
7314 if (omp_requires
& OMP_REQ_DYNAMIC_ALLOCATORS
)
7315 omp_requires_mask
= (enum omp_requires
) (omp_requires_mask
7316 | OMP_REQUIRES_DYNAMIC_ALLOCATORS
);
7317 /* Do the parse tree dump. */
7318 gfc_current_ns
= flag_dump_fortran_original
? gfc_global_ns_list
: NULL
;
7320 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
7321 if (!gfc_current_ns
->proc_name
7322 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7324 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
7325 fputs ("------------------------------------------\n\n", stdout
);
7328 /* Dump C prototypes. */
7329 if (flag_c_prototypes
|| flag_c_prototypes_external
)
7332 "#include <stddef.h>\n"
7333 "#ifdef __cplusplus\n"
7334 "#include <complex>\n"
7335 "#define __GFORTRAN_FLOAT_COMPLEX std::complex<float>\n"
7336 "#define __GFORTRAN_DOUBLE_COMPLEX std::complex<double>\n"
7337 "#define __GFORTRAN_LONG_DOUBLE_COMPLEX std::complex<long double>\n"
7340 "#define __GFORTRAN_FLOAT_COMPLEX float _Complex\n"
7341 "#define __GFORTRAN_DOUBLE_COMPLEX double _Complex\n"
7342 "#define __GFORTRAN_LONG_DOUBLE_COMPLEX long double _Complex\n"
7346 /* First dump BIND(C) prototypes. */
7347 if (flag_c_prototypes
)
7349 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
7350 gfc_current_ns
= gfc_current_ns
->sibling
)
7351 gfc_dump_c_prototypes (gfc_current_ns
, stdout
);
7354 /* Dump external prototypes. */
7355 if (flag_c_prototypes_external
)
7356 gfc_dump_external_c_prototypes (stdout
);
7358 if (flag_c_prototypes
|| flag_c_prototypes_external
)
7359 fprintf (stdout
, "\n#ifdef __cplusplus\n}\n#endif\n");
7361 /* Do the translation. */
7362 translate_all_program_units (gfc_global_ns_list
);
7364 /* Dump the global symbol ist. We only do this here because part
7365 of it is generated after mangling the identifiers in
7368 if (flag_dump_fortran_global
)
7369 gfc_dump_global_symbols (stdout
);
7371 gfc_end_source_files ();
7375 /* If we see a duplicate main program, shut down. If the second
7376 instance is an implied main program, i.e. data decls or executable
7377 statements, we're in for lots of errors. */
7378 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
7379 reject_statement ();
7384 /* Return true if this state data represents an OpenACC region. */
7386 is_oacc (gfc_state_data
*sd
)
7388 switch (sd
->construct
->op
)
7390 case EXEC_OACC_PARALLEL_LOOP
:
7391 case EXEC_OACC_PARALLEL
:
7392 case EXEC_OACC_KERNELS_LOOP
:
7393 case EXEC_OACC_KERNELS
:
7394 case EXEC_OACC_SERIAL_LOOP
:
7395 case EXEC_OACC_SERIAL
:
7396 case EXEC_OACC_DATA
:
7397 case EXEC_OACC_HOST_DATA
:
7398 case EXEC_OACC_LOOP
:
7399 case EXEC_OACC_UPDATE
:
7400 case EXEC_OACC_WAIT
:
7401 case EXEC_OACC_CACHE
:
7402 case EXEC_OACC_ENTER_DATA
:
7403 case EXEC_OACC_EXIT_DATA
:
7404 case EXEC_OACC_ATOMIC
:
7405 case EXEC_OACC_ROUTINE
: