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 ();
1803 gfc_save_module_list ();
1805 gfc_new_block
= NULL
;
1807 gfc_current_ns
->old_equiv
= gfc_current_ns
->equiv
;
1808 gfc_current_ns
->old_data
= gfc_current_ns
->data
;
1811 gfc_statement_label
= NULL
;
1812 gfc_buffer_error (true);
1815 gfc_advance_line ();
1817 gfc_skip_comments ();
1825 if (gfc_define_undef_line ())
1828 old_locus
= gfc_current_locus
;
1830 st
= (gfc_current_form
== FORM_FIXED
) ? next_fixed () : next_free ();
1836 gfc_buffer_error (false);
1838 if (st
== ST_GET_FCN_CHARACTERISTICS
)
1840 if (gfc_statement_label
!= NULL
)
1842 gfc_free_st_label (gfc_statement_label
);
1843 gfc_statement_label
= NULL
;
1845 gfc_current_locus
= old_locus
;
1849 check_statement_label (st
);
1855 /****************************** Parser ***********************************/
1857 /* The parser subroutines are of type 'try' that fail if the file ends
1860 /* Macros that expand to case-labels for various classes of
1861 statements. Start with executable statements that directly do
1864 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1865 case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1866 case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1867 case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1868 case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1869 case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1870 case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1871 case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1872 case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1873 case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: case ST_OMP_DEPOBJ: \
1874 case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
1875 case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: case ST_OMP_ERROR: \
1876 case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \
1877 case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1878 case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
1879 case ST_END_TEAM: case ST_SYNC_TEAM: \
1880 case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
1881 case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1882 case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1884 /* Statements that mark other executable statements. */
1886 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1887 case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1888 case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1889 case ST_SELECT_RANK: case ST_OMP_PARALLEL: case ST_OMP_PARALLEL_MASKED: \
1890 case ST_OMP_PARALLEL_MASKED_TASKLOOP: \
1891 case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: case ST_OMP_PARALLEL_MASTER: \
1892 case ST_OMP_PARALLEL_MASTER_TASKLOOP: \
1893 case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: \
1894 case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1895 case ST_OMP_CRITICAL: case ST_OMP_MASKED: case ST_OMP_MASKED_TASKLOOP: \
1896 case ST_OMP_MASKED_TASKLOOP_SIMD: \
1897 case ST_OMP_MASTER: case ST_OMP_MASTER_TASKLOOP: \
1898 case ST_OMP_MASTER_TASKLOOP_SIMD: case ST_OMP_SCOPE: case ST_OMP_SINGLE: \
1899 case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1900 case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1901 case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1902 case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1903 case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1904 case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1905 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1906 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1907 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1908 case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1909 case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1910 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1911 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1912 case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1913 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \
1914 case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \
1915 case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
1916 case ST_OMP_LOOP: case ST_OMP_PARALLEL_LOOP: case ST_OMP_TEAMS_LOOP: \
1917 case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_TEAMS_LOOP: \
1918 case ST_OMP_ALLOCATE_EXEC: case ST_OMP_ALLOCATORS: case ST_OMP_ASSUME: \
1920 case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1921 case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
1922 case ST_OACC_KERNELS_LOOP: case ST_OACC_SERIAL_LOOP: case ST_OACC_SERIAL: \
1925 /* Declaration statements */
1927 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1928 case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1929 case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE
1931 /* OpenMP and OpenACC declaration statements, which may appear anywhere in
1932 the specification part. */
1934 #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
1935 case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \
1936 case ST_OMP_DECLARE_VARIANT: case ST_OMP_ALLOCATE: case ST_OMP_ASSUMES: \
1937 case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
1939 /* Block end statements. Errors associated with interchanging these
1940 are detected in gfc_match_end(). */
1942 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1943 case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1944 case ST_END_BLOCK: case ST_END_ASSOCIATE
1947 /* Push a new state onto the stack. */
1950 push_state (gfc_state_data
*p
, gfc_compile_state new_state
, gfc_symbol
*sym
)
1952 p
->state
= new_state
;
1953 p
->previous
= gfc_state_stack
;
1955 p
->head
= p
->tail
= NULL
;
1956 p
->do_variable
= NULL
;
1957 if (p
->state
!= COMP_DO
&& p
->state
!= COMP_DO_CONCURRENT
)
1958 p
->ext
.oacc_declare_clauses
= NULL
;
1960 /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1961 construct statement was accepted right before pushing the state. Thus,
1962 the construct's gfc_code is available as tail of the parent state. */
1963 gcc_assert (gfc_state_stack
);
1964 p
->construct
= gfc_state_stack
->tail
;
1966 gfc_state_stack
= p
;
1970 /* Pop the current state. */
1974 gfc_state_stack
= gfc_state_stack
->previous
;
1978 /* Try to find the given state in the state stack. */
1981 gfc_find_state (gfc_compile_state state
)
1985 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1986 if (p
->state
== state
)
1989 return (p
== NULL
) ? false : true;
1993 /* Starts a new level in the statement list. */
1996 new_level (gfc_code
*q
)
2000 p
= q
->block
= gfc_get_code (EXEC_NOP
);
2002 gfc_state_stack
->head
= gfc_state_stack
->tail
= p
;
2008 /* Add the current new_st code structure and adds it to the current
2009 program unit. As a side-effect, it zeroes the new_st. */
2012 add_statement (void)
2016 p
= XCNEW (gfc_code
);
2019 p
->loc
= gfc_current_locus
;
2021 if (gfc_state_stack
->head
== NULL
)
2022 gfc_state_stack
->head
= p
;
2024 gfc_state_stack
->tail
->next
= p
;
2026 while (p
->next
!= NULL
)
2029 gfc_state_stack
->tail
= p
;
2031 gfc_clear_new_st ();
2037 /* Frees everything associated with the current statement. */
2040 undo_new_statement (void)
2042 gfc_free_statements (new_st
.block
);
2043 gfc_free_statements (new_st
.next
);
2044 gfc_free_statement (&new_st
);
2045 gfc_clear_new_st ();
2049 /* If the current statement has a statement label, make sure that it
2050 is allowed to, or should have one. */
2053 check_statement_label (gfc_statement st
)
2057 if (gfc_statement_label
== NULL
)
2059 if (st
== ST_FORMAT
)
2060 gfc_error ("FORMAT statement at %L does not have a statement label",
2067 case ST_END_PROGRAM
:
2068 case ST_END_FUNCTION
:
2069 case ST_END_SUBROUTINE
:
2073 case ST_END_CRITICAL
:
2075 case ST_END_ASSOCIATE
:
2078 if (st
== ST_ENDDO
|| st
== ST_CONTINUE
)
2079 type
= ST_LABEL_DO_TARGET
;
2081 type
= ST_LABEL_TARGET
;
2085 type
= ST_LABEL_FORMAT
;
2088 /* Statement labels are not restricted from appearing on a
2089 particular line. However, there are plenty of situations
2090 where the resulting label can't be referenced. */
2093 type
= ST_LABEL_BAD_TARGET
;
2097 gfc_define_st_label (gfc_statement_label
, type
, &label_locus
);
2099 new_st
.here
= gfc_statement_label
;
2103 /* Figures out what the enclosing program unit is. This will be a
2104 function, subroutine, program, block data or module. */
2107 gfc_enclosing_unit (gfc_compile_state
* result
)
2111 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
2112 if (p
->state
== COMP_FUNCTION
|| p
->state
== COMP_SUBROUTINE
2113 || p
->state
== COMP_MODULE
|| p
->state
== COMP_SUBMODULE
2114 || p
->state
== COMP_BLOCK_DATA
|| p
->state
== COMP_PROGRAM
)
2123 *result
= COMP_PROGRAM
;
2128 /* Translate a statement enum to a string. If strip_sentinel is true,
2129 the !$OMP/!$ACC sentinel is excluded. */
2132 gfc_ascii_statement (gfc_statement st
, bool strip_sentinel
)
2138 case ST_ARITHMETIC_IF
:
2139 p
= _("arithmetic IF");
2148 p
= _("attribute declaration");
2184 p
= _("data declaration");
2198 case ST_STRUCTURE_DECL
:
2201 case ST_DERIVED_DECL
:
2202 p
= _("derived type declaration");
2225 case ST_CHANGE_TEAM
:
2237 case ST_END_ASSOCIATE
:
2238 p
= "END ASSOCIATE";
2243 case ST_END_BLOCK_DATA
:
2244 p
= "END BLOCK DATA";
2246 case ST_END_CRITICAL
:
2258 case ST_END_FUNCTION
:
2264 case ST_END_INTERFACE
:
2265 p
= "END INTERFACE";
2270 case ST_END_SUBMODULE
:
2271 p
= "END SUBMODULE";
2273 case ST_END_PROGRAM
:
2279 case ST_END_SUBROUTINE
:
2280 p
= "END SUBROUTINE";
2285 case ST_END_STRUCTURE
:
2286 p
= "END STRUCTURE";
2300 case ST_EQUIVALENCE
:
2312 case ST_FORALL_BLOCK
: /* Fall through */
2334 case ST_IMPLICIT_NONE
:
2335 p
= "IMPLICIT NONE";
2337 case ST_IMPLIED_ENDDO
:
2338 p
= _("implied END DO");
2370 case ST_MODULE_PROC
:
2371 p
= "MODULE PROCEDURE";
2403 case ST_SYNC_IMAGES
:
2406 case ST_SYNC_MEMORY
:
2421 case ST_WHERE_BLOCK
: /* Fall through */
2432 p
= _("assignment");
2434 case ST_POINTER_ASSIGNMENT
:
2435 p
= _("pointer assignment");
2437 case ST_SELECT_CASE
:
2440 case ST_SELECT_TYPE
:
2443 case ST_SELECT_RANK
:
2461 case ST_STATEMENT_FUNCTION
:
2462 p
= "STATEMENT FUNCTION";
2464 case ST_LABEL_ASSIGNMENT
:
2465 p
= "LABEL ASSIGNMENT";
2468 p
= "ENUM DEFINITION";
2471 p
= "ENUMERATOR DEFINITION";
2476 case ST_OACC_PARALLEL_LOOP
:
2477 p
= "!$ACC PARALLEL LOOP";
2479 case ST_OACC_END_PARALLEL_LOOP
:
2480 p
= "!$ACC END PARALLEL LOOP";
2482 case ST_OACC_PARALLEL
:
2483 p
= "!$ACC PARALLEL";
2485 case ST_OACC_END_PARALLEL
:
2486 p
= "!$ACC END PARALLEL";
2488 case ST_OACC_KERNELS
:
2489 p
= "!$ACC KERNELS";
2491 case ST_OACC_END_KERNELS
:
2492 p
= "!$ACC END KERNELS";
2494 case ST_OACC_KERNELS_LOOP
:
2495 p
= "!$ACC KERNELS LOOP";
2497 case ST_OACC_END_KERNELS_LOOP
:
2498 p
= "!$ACC END KERNELS LOOP";
2500 case ST_OACC_SERIAL_LOOP
:
2501 p
= "!$ACC SERIAL LOOP";
2503 case ST_OACC_END_SERIAL_LOOP
:
2504 p
= "!$ACC END SERIAL LOOP";
2506 case ST_OACC_SERIAL
:
2509 case ST_OACC_END_SERIAL
:
2510 p
= "!$ACC END SERIAL";
2515 case ST_OACC_END_DATA
:
2516 p
= "!$ACC END DATA";
2518 case ST_OACC_HOST_DATA
:
2519 p
= "!$ACC HOST_DATA";
2521 case ST_OACC_END_HOST_DATA
:
2522 p
= "!$ACC END HOST_DATA";
2527 case ST_OACC_END_LOOP
:
2528 p
= "!$ACC END LOOP";
2530 case ST_OACC_DECLARE
:
2531 p
= "!$ACC DECLARE";
2533 case ST_OACC_UPDATE
:
2542 case ST_OACC_ENTER_DATA
:
2543 p
= "!$ACC ENTER DATA";
2545 case ST_OACC_EXIT_DATA
:
2546 p
= "!$ACC EXIT DATA";
2548 case ST_OACC_ROUTINE
:
2549 p
= "!$ACC ROUTINE";
2551 case ST_OACC_ATOMIC
:
2554 case ST_OACC_END_ATOMIC
:
2555 p
= "!$ACC END ATOMIC";
2557 case ST_OMP_ALLOCATE
:
2558 case ST_OMP_ALLOCATE_EXEC
:
2559 p
= "!$OMP ALLOCATE";
2561 case ST_OMP_ALLOCATORS
:
2562 p
= "!$OMP ALLOCATORS";
2567 case ST_OMP_ASSUMES
:
2568 p
= "!$OMP ASSUMES";
2573 case ST_OMP_BARRIER
:
2574 p
= "!$OMP BARRIER";
2579 case ST_OMP_CANCELLATION_POINT
:
2580 p
= "!$OMP CANCELLATION POINT";
2582 case ST_OMP_CRITICAL
:
2583 p
= "!$OMP CRITICAL";
2585 case ST_OMP_DECLARE_REDUCTION
:
2586 p
= "!$OMP DECLARE REDUCTION";
2588 case ST_OMP_DECLARE_SIMD
:
2589 p
= "!$OMP DECLARE SIMD";
2591 case ST_OMP_DECLARE_TARGET
:
2592 p
= "!$OMP DECLARE TARGET";
2594 case ST_OMP_DECLARE_VARIANT
:
2595 p
= "!$OMP DECLARE VARIANT";
2600 case ST_OMP_DISTRIBUTE
:
2601 p
= "!$OMP DISTRIBUTE";
2603 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
2604 p
= "!$OMP DISTRIBUTE PARALLEL DO";
2606 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
2607 p
= "!$OMP DISTRIBUTE PARALLEL DO SIMD";
2609 case ST_OMP_DISTRIBUTE_SIMD
:
2610 p
= "!$OMP DISTRIBUTE SIMD";
2615 case ST_OMP_DO_SIMD
:
2616 p
= "!$OMP DO SIMD";
2618 case ST_OMP_END_ALLOCATORS
:
2619 p
= "!$OMP END ALLOCATORS";
2621 case ST_OMP_END_ASSUME
:
2622 p
= "!$OMP END ASSUME";
2624 case ST_OMP_END_ATOMIC
:
2625 p
= "!$OMP END ATOMIC";
2627 case ST_OMP_END_CRITICAL
:
2628 p
= "!$OMP END CRITICAL";
2630 case ST_OMP_END_DISTRIBUTE
:
2631 p
= "!$OMP END DISTRIBUTE";
2633 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO
:
2634 p
= "!$OMP END DISTRIBUTE PARALLEL DO";
2636 case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
:
2637 p
= "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
2639 case ST_OMP_END_DISTRIBUTE_SIMD
:
2640 p
= "!$OMP END DISTRIBUTE SIMD";
2645 case ST_OMP_END_DO_SIMD
:
2646 p
= "!$OMP END DO SIMD";
2648 case ST_OMP_END_SCOPE
:
2649 p
= "!$OMP END SCOPE";
2651 case ST_OMP_END_SIMD
:
2652 p
= "!$OMP END SIMD";
2654 case ST_OMP_END_LOOP
:
2655 p
= "!$OMP END LOOP";
2657 case ST_OMP_END_MASKED
:
2658 p
= "!$OMP END MASKED";
2660 case ST_OMP_END_MASKED_TASKLOOP
:
2661 p
= "!$OMP END MASKED TASKLOOP";
2663 case ST_OMP_END_MASKED_TASKLOOP_SIMD
:
2664 p
= "!$OMP END MASKED TASKLOOP SIMD";
2666 case ST_OMP_END_MASTER
:
2667 p
= "!$OMP END MASTER";
2669 case ST_OMP_END_MASTER_TASKLOOP
:
2670 p
= "!$OMP END MASTER TASKLOOP";
2672 case ST_OMP_END_MASTER_TASKLOOP_SIMD
:
2673 p
= "!$OMP END MASTER TASKLOOP SIMD";
2675 case ST_OMP_END_ORDERED
:
2676 p
= "!$OMP END ORDERED";
2678 case ST_OMP_END_PARALLEL
:
2679 p
= "!$OMP END PARALLEL";
2681 case ST_OMP_END_PARALLEL_DO
:
2682 p
= "!$OMP END PARALLEL DO";
2684 case ST_OMP_END_PARALLEL_DO_SIMD
:
2685 p
= "!$OMP END PARALLEL DO SIMD";
2687 case ST_OMP_END_PARALLEL_LOOP
:
2688 p
= "!$OMP END PARALLEL LOOP";
2690 case ST_OMP_END_PARALLEL_MASKED
:
2691 p
= "!$OMP END PARALLEL MASKED";
2693 case ST_OMP_END_PARALLEL_MASKED_TASKLOOP
:
2694 p
= "!$OMP END PARALLEL MASKED TASKLOOP";
2696 case ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD
:
2697 p
= "!$OMP END PARALLEL MASKED TASKLOOP SIMD";
2699 case ST_OMP_END_PARALLEL_MASTER
:
2700 p
= "!$OMP END PARALLEL MASTER";
2702 case ST_OMP_END_PARALLEL_MASTER_TASKLOOP
:
2703 p
= "!$OMP END PARALLEL MASTER TASKLOOP";
2705 case ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD
:
2706 p
= "!$OMP END PARALLEL MASTER TASKLOOP SIMD";
2708 case ST_OMP_END_PARALLEL_SECTIONS
:
2709 p
= "!$OMP END PARALLEL SECTIONS";
2711 case ST_OMP_END_PARALLEL_WORKSHARE
:
2712 p
= "!$OMP END PARALLEL WORKSHARE";
2714 case ST_OMP_END_SECTIONS
:
2715 p
= "!$OMP END SECTIONS";
2717 case ST_OMP_END_SINGLE
:
2718 p
= "!$OMP END SINGLE";
2720 case ST_OMP_END_TASK
:
2721 p
= "!$OMP END TASK";
2723 case ST_OMP_END_TARGET
:
2724 p
= "!$OMP END TARGET";
2726 case ST_OMP_END_TARGET_DATA
:
2727 p
= "!$OMP END TARGET DATA";
2729 case ST_OMP_END_TARGET_PARALLEL
:
2730 p
= "!$OMP END TARGET PARALLEL";
2732 case ST_OMP_END_TARGET_PARALLEL_DO
:
2733 p
= "!$OMP END TARGET PARALLEL DO";
2735 case ST_OMP_END_TARGET_PARALLEL_DO_SIMD
:
2736 p
= "!$OMP END TARGET PARALLEL DO SIMD";
2738 case ST_OMP_END_TARGET_PARALLEL_LOOP
:
2739 p
= "!$OMP END TARGET PARALLEL LOOP";
2741 case ST_OMP_END_TARGET_SIMD
:
2742 p
= "!$OMP END TARGET SIMD";
2744 case ST_OMP_END_TARGET_TEAMS
:
2745 p
= "!$OMP END TARGET TEAMS";
2747 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
:
2748 p
= "!$OMP END TARGET TEAMS DISTRIBUTE";
2750 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2751 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2753 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2754 p
= "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2756 case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2757 p
= "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2759 case ST_OMP_END_TARGET_TEAMS_LOOP
:
2760 p
= "!$OMP END TARGET TEAMS LOOP";
2762 case ST_OMP_END_TASKGROUP
:
2763 p
= "!$OMP END TASKGROUP";
2765 case ST_OMP_END_TASKLOOP
:
2766 p
= "!$OMP END TASKLOOP";
2768 case ST_OMP_END_TASKLOOP_SIMD
:
2769 p
= "!$OMP END TASKLOOP SIMD";
2771 case ST_OMP_END_TEAMS
:
2772 p
= "!$OMP END TEAMS";
2774 case ST_OMP_END_TEAMS_DISTRIBUTE
:
2775 p
= "!$OMP END TEAMS DISTRIBUTE";
2777 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2778 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2780 case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2781 p
= "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2783 case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
:
2784 p
= "!$OMP END TEAMS DISTRIBUTE SIMD";
2786 case ST_OMP_END_TEAMS_LOOP
:
2787 p
= "!$OMP END TEAMS LOOP";
2789 case ST_OMP_END_WORKSHARE
:
2790 p
= "!$OMP END WORKSHARE";
2804 case ST_OMP_MASKED_TASKLOOP
:
2805 p
= "!$OMP MASKED TASKLOOP";
2807 case ST_OMP_MASKED_TASKLOOP_SIMD
:
2808 p
= "!$OMP MASKED TASKLOOP SIMD";
2813 case ST_OMP_MASTER_TASKLOOP
:
2814 p
= "!$OMP MASTER TASKLOOP";
2816 case ST_OMP_MASTER_TASKLOOP_SIMD
:
2817 p
= "!$OMP MASTER TASKLOOP SIMD";
2819 case ST_OMP_ORDERED
:
2820 case ST_OMP_ORDERED_DEPEND
:
2821 p
= "!$OMP ORDERED";
2823 case ST_OMP_NOTHING
:
2824 /* Note: gfc_match_omp_nothing returns ST_NONE. */
2825 p
= "!$OMP NOTHING";
2827 case ST_OMP_PARALLEL
:
2828 p
= "!$OMP PARALLEL";
2830 case ST_OMP_PARALLEL_DO
:
2831 p
= "!$OMP PARALLEL DO";
2833 case ST_OMP_PARALLEL_LOOP
:
2834 p
= "!$OMP PARALLEL LOOP";
2836 case ST_OMP_PARALLEL_DO_SIMD
:
2837 p
= "!$OMP PARALLEL DO SIMD";
2839 case ST_OMP_PARALLEL_MASKED
:
2840 p
= "!$OMP PARALLEL MASKED";
2842 case ST_OMP_PARALLEL_MASKED_TASKLOOP
:
2843 p
= "!$OMP PARALLEL MASKED TASKLOOP";
2845 case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
2846 p
= "!$OMP PARALLEL MASKED TASKLOOP SIMD";
2848 case ST_OMP_PARALLEL_MASTER
:
2849 p
= "!$OMP PARALLEL MASTER";
2851 case ST_OMP_PARALLEL_MASTER_TASKLOOP
:
2852 p
= "!$OMP PARALLEL MASTER TASKLOOP";
2854 case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
2855 p
= "!$OMP PARALLEL MASTER TASKLOOP SIMD";
2857 case ST_OMP_PARALLEL_SECTIONS
:
2858 p
= "!$OMP PARALLEL SECTIONS";
2860 case ST_OMP_PARALLEL_WORKSHARE
:
2861 p
= "!$OMP PARALLEL WORKSHARE";
2863 case ST_OMP_REQUIRES
:
2864 p
= "!$OMP REQUIRES";
2872 case ST_OMP_SECTIONS
:
2873 p
= "!$OMP SECTIONS";
2875 case ST_OMP_SECTION
:
2876 p
= "!$OMP SECTION";
2887 case ST_OMP_TARGET_DATA
:
2888 p
= "!$OMP TARGET DATA";
2890 case ST_OMP_TARGET_ENTER_DATA
:
2891 p
= "!$OMP TARGET ENTER DATA";
2893 case ST_OMP_TARGET_EXIT_DATA
:
2894 p
= "!$OMP TARGET EXIT DATA";
2896 case ST_OMP_TARGET_PARALLEL
:
2897 p
= "!$OMP TARGET PARALLEL";
2899 case ST_OMP_TARGET_PARALLEL_DO
:
2900 p
= "!$OMP TARGET PARALLEL DO";
2902 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
2903 p
= "!$OMP TARGET PARALLEL DO SIMD";
2905 case ST_OMP_TARGET_PARALLEL_LOOP
:
2906 p
= "!$OMP TARGET PARALLEL LOOP";
2908 case ST_OMP_TARGET_SIMD
:
2909 p
= "!$OMP TARGET SIMD";
2911 case ST_OMP_TARGET_TEAMS
:
2912 p
= "!$OMP TARGET TEAMS";
2914 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
2915 p
= "!$OMP TARGET TEAMS DISTRIBUTE";
2917 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2918 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2920 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2921 p
= "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2923 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
2924 p
= "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2926 case ST_OMP_TARGET_TEAMS_LOOP
:
2927 p
= "!$OMP TARGET TEAMS LOOP";
2929 case ST_OMP_TARGET_UPDATE
:
2930 p
= "!$OMP TARGET UPDATE";
2935 case ST_OMP_TASKGROUP
:
2936 p
= "!$OMP TASKGROUP";
2938 case ST_OMP_TASKLOOP
:
2939 p
= "!$OMP TASKLOOP";
2941 case ST_OMP_TASKLOOP_SIMD
:
2942 p
= "!$OMP TASKLOOP SIMD";
2944 case ST_OMP_TASKWAIT
:
2945 p
= "!$OMP TASKWAIT";
2947 case ST_OMP_TASKYIELD
:
2948 p
= "!$OMP TASKYIELD";
2953 case ST_OMP_TEAMS_DISTRIBUTE
:
2954 p
= "!$OMP TEAMS DISTRIBUTE";
2956 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
2957 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2959 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
2960 p
= "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2962 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
2963 p
= "!$OMP TEAMS DISTRIBUTE SIMD";
2965 case ST_OMP_TEAMS_LOOP
:
2966 p
= "!$OMP TEAMS LOOP";
2968 case ST_OMP_THREADPRIVATE
:
2969 p
= "!$OMP THREADPRIVATE";
2971 case ST_OMP_WORKSHARE
:
2972 p
= "!$OMP WORKSHARE";
2975 gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2978 if (strip_sentinel
&& p
[0] == '!')
2979 return p
+ strlen ("!$OMP ");
2984 /* Create a symbol for the main program and assign it to ns->proc_name. */
2987 main_program_symbol (gfc_namespace
*ns
, const char *name
)
2989 gfc_symbol
*main_program
;
2990 symbol_attribute attr
;
2992 gfc_get_symbol (name
, ns
, &main_program
);
2993 gfc_clear_attr (&attr
);
2994 attr
.flavor
= FL_PROGRAM
;
2995 attr
.proc
= PROC_UNKNOWN
;
2996 attr
.subroutine
= 1;
2997 attr
.access
= ACCESS_PUBLIC
;
2998 attr
.is_main_program
= 1;
2999 main_program
->attr
= attr
;
3000 main_program
->declared_at
= gfc_current_locus
;
3001 ns
->proc_name
= main_program
;
3002 gfc_commit_symbols ();
3006 /* Do whatever is necessary to accept the last statement. */
3009 accept_statement (gfc_statement st
)
3013 case ST_IMPLICIT_NONE
:
3021 gfc_current_ns
->proc_name
= gfc_new_block
;
3024 /* If the statement is the end of a block, lay down a special code
3025 that allows a branch to the end of the block from within the
3026 construct. IF and SELECT are treated differently from DO
3027 (where EXEC_NOP is added inside the loop) for two
3029 1. END DO has a meaning in the sense that after a GOTO to
3030 it, the loop counter must be increased.
3031 2. IF blocks and SELECT blocks can consist of multiple
3032 parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
3033 Putting the label before the END IF would make the jump
3034 from, say, the ELSE IF block to the END IF illegal. */
3038 case ST_END_CRITICAL
:
3039 if (gfc_statement_label
!= NULL
)
3041 new_st
.op
= EXEC_END_NESTED_BLOCK
;
3046 /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
3047 one parallel block. Thus, we add the special code to the nested block
3048 itself, instead of the parent one. */
3050 case ST_END_ASSOCIATE
:
3051 if (gfc_statement_label
!= NULL
)
3053 new_st
.op
= EXEC_END_BLOCK
;
3058 /* The end-of-program unit statements do not get the special
3059 marker and require a statement of some sort if they are a
3062 case ST_END_PROGRAM
:
3063 case ST_END_FUNCTION
:
3064 case ST_END_SUBROUTINE
:
3065 if (gfc_statement_label
!= NULL
)
3067 new_st
.op
= EXEC_RETURN
;
3072 new_st
.op
= EXEC_END_PROCEDURE
;
3088 gfc_commit_symbols ();
3089 gfc_warning_check ();
3090 gfc_clear_new_st ();
3094 /* Undo anything tentative that has been built for the current statement,
3095 except if a gfc_charlen structure has been added to current namespace's
3096 list of gfc_charlen structure. */
3099 reject_statement (void)
3101 gfc_free_equiv_until (gfc_current_ns
->equiv
, gfc_current_ns
->old_equiv
);
3102 gfc_current_ns
->equiv
= gfc_current_ns
->old_equiv
;
3103 gfc_drop_interface_elements_before (current_interface_ptr
,
3104 previous_interface_head
);
3106 gfc_reject_data (gfc_current_ns
);
3108 /* Don't queue use-association of a module if we reject the use statement. */
3109 gfc_restore_old_module_list ();
3111 gfc_new_block
= NULL
;
3112 gfc_undo_symbols ();
3113 gfc_clear_warning ();
3114 undo_new_statement ();
3118 /* Generic complaint about an out of order statement. We also do
3119 whatever is necessary to clean up. */
3122 unexpected_statement (gfc_statement st
)
3124 gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st
));
3126 reject_statement ();
3130 /* Given the next statement seen by the matcher, make sure that it is
3131 in proper order with the last. This subroutine is initialized by
3132 calling it with an argument of ST_NONE. If there is a problem, we
3133 issue an error and return false. Otherwise we return true.
3135 Individual parsers need to verify that the statements seen are
3136 valid before calling here, i.e., ENTRY statements are not allowed in
3137 INTERFACE blocks. The following diagram is taken from the standard:
3139 +---------------------------------------+
3140 | program subroutine function module |
3141 +---------------------------------------+
3143 +---------------------------------------+
3145 +---------------------------------------+
3147 | +-----------+------------------+
3148 | | parameter | implicit |
3149 | +-----------+------------------+
3150 | format | | derived type |
3151 | entry | parameter | interface |
3152 | | data | specification |
3153 | | | statement func |
3154 | +-----------+------------------+
3155 | | data | executable |
3156 +--------+-----------+------------------+
3158 +---------------------------------------+
3159 | internal module/subprogram |
3160 +---------------------------------------+
3162 +---------------------------------------+
3171 ORDER_IMPLICIT_NONE
,
3179 enum state_order state
;
3180 gfc_statement last_statement
;
3186 verify_st_order (st_state
*p
, gfc_statement st
, bool silent
)
3192 p
->state
= ORDER_START
;
3193 in_exec_part
= false;
3197 if (p
->state
> ORDER_USE
)
3199 p
->state
= ORDER_USE
;
3203 if (p
->state
> ORDER_IMPORT
)
3205 p
->state
= ORDER_IMPORT
;
3208 case ST_IMPLICIT_NONE
:
3209 if (p
->state
> ORDER_IMPLICIT
)
3212 /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
3213 statement disqualifies a USE but not an IMPLICIT NONE.
3214 Duplicate IMPLICIT NONEs are caught when the implicit types
3217 p
->state
= ORDER_IMPLICIT_NONE
;
3221 if (p
->state
> ORDER_IMPLICIT
)
3223 p
->state
= ORDER_IMPLICIT
;
3228 if (p
->state
< ORDER_IMPLICIT_NONE
)
3229 p
->state
= ORDER_IMPLICIT_NONE
;
3233 if (p
->state
>= ORDER_EXEC
)
3235 if (p
->state
< ORDER_IMPLICIT
)
3236 p
->state
= ORDER_IMPLICIT
;
3240 if (p
->state
< ORDER_SPEC
)
3241 p
->state
= ORDER_SPEC
;
3246 case ST_STRUCTURE_DECL
:
3247 case ST_DERIVED_DECL
:
3249 if (p
->state
>= ORDER_EXEC
)
3251 if (p
->state
< ORDER_SPEC
)
3252 p
->state
= ORDER_SPEC
;
3256 /* The OpenMP/OpenACC directives have to be somewhere in the specification
3257 part, but there are no further requirements on their ordering.
3258 Thus don't adjust p->state, just ignore them. */
3259 if (p
->state
>= ORDER_EXEC
)
3265 if (p
->state
< ORDER_EXEC
)
3266 p
->state
= ORDER_EXEC
;
3267 in_exec_part
= true;
3274 /* All is well, record the statement in case we need it next time. */
3275 p
->where
= gfc_current_locus
;
3276 p
->last_statement
= st
;
3281 gfc_error ("%s statement at %C cannot follow %s statement at %L",
3282 gfc_ascii_statement (st
),
3283 gfc_ascii_statement (p
->last_statement
), &p
->where
);
3289 /* Handle an unexpected end of file. This is a show-stopper... */
3291 static void unexpected_eof (void) ATTRIBUTE_NORETURN
;
3294 unexpected_eof (void)
3298 gfc_error ("Unexpected end of file in %qs", gfc_source_file
);
3300 /* Memory cleanup. Move to "second to last". */
3301 for (p
= gfc_state_stack
; p
&& p
->previous
&& p
->previous
->previous
;
3304 gfc_current_ns
->code
= (p
&& p
->previous
) ? p
->head
: NULL
;
3307 longjmp (eof_buf
, 1);
3309 /* Avoids build error on systems where longjmp is not declared noreturn. */
3314 /* Parse the CONTAINS section of a derived type definition. */
3316 gfc_access gfc_typebound_default_access
;
3319 parse_derived_contains (void)
3322 bool seen_private
= false;
3323 bool seen_comps
= false;
3324 bool error_flag
= false;
3327 gcc_assert (gfc_current_state () == COMP_DERIVED
);
3328 gcc_assert (gfc_current_block ());
3330 /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
3332 if (gfc_current_block ()->attr
.sequence
)
3333 gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
3334 " section at %C", gfc_current_block ()->name
);
3335 if (gfc_current_block ()->attr
.is_bind_c
)
3336 gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
3337 " section at %C", gfc_current_block ()->name
);
3339 accept_statement (ST_CONTAINS
);
3340 push_state (&s
, COMP_DERIVED_CONTAINS
, NULL
);
3342 gfc_typebound_default_access
= ACCESS_PUBLIC
;
3348 st
= next_statement ();
3356 gfc_error ("Components in TYPE at %C must precede CONTAINS");
3360 if (!gfc_notify_std (GFC_STD_F2003
, "Type-bound procedure at %C"))
3363 accept_statement (ST_PROCEDURE
);
3368 if (!gfc_notify_std (GFC_STD_F2003
, "GENERIC binding at %C"))
3371 accept_statement (ST_GENERIC
);
3376 if (!gfc_notify_std (GFC_STD_F2003
, "FINAL procedure declaration"
3380 accept_statement (ST_FINAL
);
3388 && (!gfc_notify_std(GFC_STD_F2008
, "Derived type definition "
3389 "at %C with empty CONTAINS section")))
3392 /* ST_END_TYPE is accepted by parse_derived after return. */
3396 if (!gfc_find_state (COMP_MODULE
))
3398 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3405 gfc_error ("PRIVATE statement at %C must precede procedure"
3412 gfc_error ("Duplicate PRIVATE statement at %C");
3416 accept_statement (ST_PRIVATE
);
3417 gfc_typebound_default_access
= ACCESS_PRIVATE
;
3418 seen_private
= true;
3422 gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
3426 gfc_error ("Already inside a CONTAINS block at %C");
3430 unexpected_statement (st
);
3438 reject_statement ();
3442 gcc_assert (gfc_current_state () == COMP_DERIVED
);
3448 /* Set attributes for the parent symbol based on the attributes of a component
3449 and raise errors if conflicting attributes are found for the component. */
3452 check_component (gfc_symbol
*sym
, gfc_component
*c
, gfc_component
**lockp
,
3453 gfc_component
**eventp
)
3455 bool coarray
, lock_type
, event_type
, allocatable
, pointer
;
3456 coarray
= lock_type
= event_type
= allocatable
= pointer
= false;
3457 gfc_component
*lock_comp
= NULL
, *event_comp
= NULL
;
3459 if (lockp
) lock_comp
= *lockp
;
3460 if (eventp
) event_comp
= *eventp
;
3462 /* Look for allocatable components. */
3463 if (c
->attr
.allocatable
3464 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3465 && CLASS_DATA (c
)->attr
.allocatable
)
3466 || (c
->ts
.type
== BT_DERIVED
&& !c
->attr
.pointer
3467 && c
->ts
.u
.derived
->attr
.alloc_comp
))
3470 sym
->attr
.alloc_comp
= 1;
3473 /* Look for pointer components. */
3475 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3476 && CLASS_DATA (c
)->attr
.class_pointer
)
3477 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.pointer_comp
))
3480 sym
->attr
.pointer_comp
= 1;
3483 /* Look for procedure pointer components. */
3484 if (c
->attr
.proc_pointer
3485 || (c
->ts
.type
== BT_DERIVED
3486 && c
->ts
.u
.derived
->attr
.proc_pointer_comp
))
3487 sym
->attr
.proc_pointer_comp
= 1;
3489 /* Looking for coarray components. */
3490 if (c
->attr
.codimension
3491 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3492 && CLASS_DATA (c
)->attr
.codimension
))
3495 sym
->attr
.coarray_comp
= 1;
3498 if (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.coarray_comp
3499 && !c
->attr
.pointer
)
3502 sym
->attr
.coarray_comp
= 1;
3505 /* Looking for lock_type components. */
3506 if ((c
->ts
.type
== BT_DERIVED
3507 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3508 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE
)
3509 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3510 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
3511 == INTMOD_ISO_FORTRAN_ENV
3512 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
3513 == ISOFORTRAN_LOCK_TYPE
)
3514 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.lock_comp
3515 && !allocatable
&& !pointer
))
3519 sym
->attr
.lock_comp
= 1;
3522 /* Looking for event_type components. */
3523 if ((c
->ts
.type
== BT_DERIVED
3524 && c
->ts
.u
.derived
->from_intmod
== INTMOD_ISO_FORTRAN_ENV
3525 && c
->ts
.u
.derived
->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE
)
3526 || (c
->ts
.type
== BT_CLASS
&& c
->attr
.class_ok
3527 && CLASS_DATA (c
)->ts
.u
.derived
->from_intmod
3528 == INTMOD_ISO_FORTRAN_ENV
3529 && CLASS_DATA (c
)->ts
.u
.derived
->intmod_sym_id
3530 == ISOFORTRAN_EVENT_TYPE
)
3531 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.event_comp
3532 && !allocatable
&& !pointer
))
3536 sym
->attr
.event_comp
= 1;
3539 /* Check for F2008, C1302 - and recall that pointers may not be coarrays
3540 (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
3541 unless there are nondirect [allocatable or pointer] components
3542 involved (cf. 1.3.33.1 and 1.3.33.3). */
3544 if (pointer
&& !coarray
&& lock_type
)
3545 gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
3546 "codimension or be a subcomponent of a coarray, "
3547 "which is not possible as the component has the "
3548 "pointer attribute", c
->name
, &c
->loc
);
3549 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
3550 && c
->ts
.u
.derived
->attr
.lock_comp
)
3551 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3552 "of type LOCK_TYPE, which must have a codimension or be a "
3553 "subcomponent of a coarray", c
->name
, &c
->loc
);
3555 if (lock_type
&& allocatable
&& !coarray
)
3556 gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
3557 "a codimension", c
->name
, &c
->loc
);
3558 else if (lock_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
3559 && c
->ts
.u
.derived
->attr
.lock_comp
)
3560 gfc_error ("Allocatable component %s at %L must have a codimension as "
3561 "it has a noncoarray subcomponent of type LOCK_TYPE",
3564 if (sym
->attr
.coarray_comp
&& !coarray
&& lock_type
)
3565 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3566 "subcomponent of type LOCK_TYPE must have a codimension or "
3567 "be a subcomponent of a coarray. (Variables of type %s may "
3568 "not have a codimension as already a coarray "
3569 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
3571 if (sym
->attr
.lock_comp
&& coarray
&& !lock_type
)
3572 gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3573 "subcomponent of type LOCK_TYPE must have a codimension or "
3574 "be a subcomponent of a coarray. (Variables of type %s may "
3575 "not have a codimension as %s at %L has a codimension or a "
3576 "coarray subcomponent)", lock_comp
->name
, &lock_comp
->loc
,
3577 sym
->name
, c
->name
, &c
->loc
);
3579 /* Similarly for EVENT TYPE. */
3581 if (pointer
&& !coarray
&& event_type
)
3582 gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
3583 "codimension or be a subcomponent of a coarray, "
3584 "which is not possible as the component has the "
3585 "pointer attribute", c
->name
, &c
->loc
);
3586 else if (pointer
&& !coarray
&& c
->ts
.type
== BT_DERIVED
3587 && c
->ts
.u
.derived
->attr
.event_comp
)
3588 gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3589 "of type EVENT_TYPE, which must have a codimension or be a "
3590 "subcomponent of a coarray", c
->name
, &c
->loc
);
3592 if (event_type
&& allocatable
&& !coarray
)
3593 gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
3594 "a codimension", c
->name
, &c
->loc
);
3595 else if (event_type
&& allocatable
&& c
->ts
.type
== BT_DERIVED
3596 && c
->ts
.u
.derived
->attr
.event_comp
)
3597 gfc_error ("Allocatable component %s at %L must have a codimension as "
3598 "it has a noncoarray subcomponent of type EVENT_TYPE",
3601 if (sym
->attr
.coarray_comp
&& !coarray
&& event_type
)
3602 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3603 "subcomponent of type EVENT_TYPE must have a codimension or "
3604 "be a subcomponent of a coarray. (Variables of type %s may "
3605 "not have a codimension as already a coarray "
3606 "subcomponent exists)", c
->name
, &c
->loc
, sym
->name
);
3608 if (sym
->attr
.event_comp
&& coarray
&& !event_type
)
3609 gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3610 "subcomponent of type EVENT_TYPE must have a codimension or "
3611 "be a subcomponent of a coarray. (Variables of type %s may "
3612 "not have a codimension as %s at %L has a codimension or a "
3613 "coarray subcomponent)", event_comp
->name
, &event_comp
->loc
,
3614 sym
->name
, c
->name
, &c
->loc
);
3616 /* Look for private components. */
3617 if (sym
->component_access
== ACCESS_PRIVATE
3618 || c
->attr
.access
== ACCESS_PRIVATE
3619 || (c
->ts
.type
== BT_DERIVED
&& c
->ts
.u
.derived
->attr
.private_comp
))
3620 sym
->attr
.private_comp
= 1;
3622 if (lockp
) *lockp
= lock_comp
;
3623 if (eventp
) *eventp
= event_comp
;
3627 static void parse_struct_map (gfc_statement
);
3629 /* Parse a union component definition within a structure definition. */
3637 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3640 accept_statement(ST_UNION
);
3641 push_state (&s
, COMP_UNION
, gfc_new_block
);
3648 st
= next_statement ();
3649 /* Only MAP declarations valid within a union. */
3656 accept_statement (ST_MAP
);
3657 parse_struct_map (ST_MAP
);
3658 /* Add a component to the union for each map. */
3659 if (!gfc_add_component (un
, gfc_new_block
->name
, &c
))
3661 gfc_internal_error ("failed to create map component '%s'",
3662 gfc_new_block
->name
);
3663 reject_statement ();
3666 c
->ts
.type
= BT_DERIVED
;
3667 c
->ts
.u
.derived
= gfc_new_block
;
3668 /* Normally components get their initialization expressions when they
3669 are created in decl.cc (build_struct) so we can look through the
3670 flat component list for initializers during resolution. Unions and
3671 maps create components along with their type definitions so we
3672 have to generate initializers here. */
3673 c
->initializer
= gfc_default_initializer (&c
->ts
);
3678 accept_statement (ST_END_UNION
);
3682 unexpected_statement (st
);
3687 for (c
= un
->components
; c
; c
= c
->next
)
3688 check_component (un
, c
, &lock_comp
, &event_comp
);
3690 /* Add the union as a component in its parent structure. */
3692 if (!gfc_add_component (gfc_current_block (), un
->name
, &c
))
3694 gfc_internal_error ("failed to create union component '%s'", un
->name
);
3695 reject_statement ();
3698 c
->ts
.type
= BT_UNION
;
3699 c
->ts
.u
.derived
= un
;
3700 c
->initializer
= gfc_default_initializer (&c
->ts
);
3702 un
->attr
.zero_comp
= un
->components
== NULL
;
3706 /* Parse a STRUCTURE or MAP. */
3709 parse_struct_map (gfc_statement block
)
3715 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3716 gfc_compile_state comp
;
3719 if (block
== ST_STRUCTURE_DECL
)
3721 comp
= COMP_STRUCTURE
;
3722 ends
= ST_END_STRUCTURE
;
3726 gcc_assert (block
== ST_MAP
);
3731 accept_statement(block
);
3732 push_state (&s
, comp
, gfc_new_block
);
3734 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3737 while (compiling_type
)
3739 st
= next_statement ();
3745 /* Nested structure declarations will be captured as ST_DATA_DECL. */
3746 case ST_STRUCTURE_DECL
:
3747 /* Let a more specific error make it to decode_statement(). */
3748 if (gfc_error_check () == 0)
3749 gfc_error ("Syntax error in nested structure declaration at %C");
3750 reject_statement ();
3751 /* Skip the rest of this statement. */
3752 gfc_error_recovery ();
3756 accept_statement (ST_UNION
);
3761 /* The data declaration was a nested/ad-hoc STRUCTURE field. */
3762 accept_statement (ST_DATA_DECL
);
3763 if (gfc_new_block
&& gfc_new_block
!= gfc_current_block ()
3764 && gfc_new_block
->attr
.flavor
== FL_STRUCT
)
3765 parse_struct_map (ST_STRUCTURE_DECL
);
3768 case ST_END_STRUCTURE
:
3772 accept_statement (st
);
3776 unexpected_statement (st
);
3780 unexpected_statement (st
);
3785 /* Validate each component. */
3786 sym
= gfc_current_block ();
3787 for (c
= sym
->components
; c
; c
= c
->next
)
3788 check_component (sym
, c
, &lock_comp
, &event_comp
);
3790 sym
->attr
.zero_comp
= (sym
->components
== NULL
);
3792 /* Allow parse_union to find this structure to add to its list of maps. */
3793 if (block
== ST_MAP
)
3794 gfc_new_block
= gfc_current_block ();
3800 /* Parse a derived type. */
3803 parse_derived (void)
3805 int compiling_type
, seen_private
, seen_sequence
, seen_component
;
3809 gfc_component
*c
, *lock_comp
= NULL
, *event_comp
= NULL
;
3811 accept_statement (ST_DERIVED_DECL
);
3812 push_state (&s
, COMP_DERIVED
, gfc_new_block
);
3814 gfc_new_block
->component_access
= ACCESS_PUBLIC
;
3821 while (compiling_type
)
3823 st
= next_statement ();
3831 accept_statement (st
);
3836 gfc_error ("FINAL declaration at %C must be inside CONTAINS");
3843 if (!seen_component
)
3844 gfc_notify_std (GFC_STD_F2003
, "Derived type "
3845 "definition at %C without components");
3847 accept_statement (ST_END_TYPE
);
3851 if (!gfc_find_state (COMP_MODULE
))
3853 gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3860 gfc_error ("PRIVATE statement at %C must precede "
3861 "structure components");
3866 gfc_error ("Duplicate PRIVATE statement at %C");
3868 s
.sym
->component_access
= ACCESS_PRIVATE
;
3870 accept_statement (ST_PRIVATE
);
3877 gfc_error ("SEQUENCE statement at %C must precede "
3878 "structure components");
3882 if (gfc_current_block ()->attr
.sequence
)
3883 gfc_warning (0, "SEQUENCE attribute at %C already specified in "
3888 gfc_error ("Duplicate SEQUENCE statement at %C");
3892 gfc_add_sequence (&gfc_current_block ()->attr
,
3893 gfc_current_block ()->name
, NULL
);
3897 gfc_notify_std (GFC_STD_F2003
,
3898 "CONTAINS block in derived type"
3899 " definition at %C");
3901 accept_statement (ST_CONTAINS
);
3902 parse_derived_contains ();
3906 unexpected_statement (st
);
3911 /* need to verify that all fields of the derived type are
3912 * interoperable with C if the type is declared to be bind(c)
3914 sym
= gfc_current_block ();
3915 for (c
= sym
->components
; c
; c
= c
->next
)
3916 check_component (sym
, c
, &lock_comp
, &event_comp
);
3918 if (!seen_component
)
3919 sym
->attr
.zero_comp
= 1;
3925 /* Parse an ENUM. */
3933 int seen_enumerator
= 0;
3935 push_state (&s
, COMP_ENUM
, gfc_new_block
);
3939 while (compiling_enum
)
3941 st
= next_statement ();
3949 seen_enumerator
= 1;
3950 accept_statement (st
);
3955 if (!seen_enumerator
)
3956 gfc_error ("ENUM declaration at %C has no ENUMERATORS");
3957 accept_statement (st
);
3961 gfc_free_enum_history ();
3962 unexpected_statement (st
);
3970 /* Parse an interface. We must be able to deal with the possibility
3971 of recursive interfaces. The parse_spec() subroutine is mutually
3972 recursive with parse_interface(). */
3974 static gfc_statement
parse_spec (gfc_statement
);
3977 parse_interface (void)
3979 gfc_compile_state new_state
= COMP_NONE
, current_state
;
3980 gfc_symbol
*prog_unit
, *sym
;
3981 gfc_interface_info save
;
3982 gfc_state_data s1
, s2
;
3985 accept_statement (ST_INTERFACE
);
3987 current_interface
.ns
= gfc_current_ns
;
3988 save
= current_interface
;
3990 sym
= (current_interface
.type
== INTERFACE_GENERIC
3991 || current_interface
.type
== INTERFACE_USER_OP
)
3992 ? gfc_new_block
: NULL
;
3994 push_state (&s1
, COMP_INTERFACE
, sym
);
3995 current_state
= COMP_NONE
;
3998 gfc_current_ns
= gfc_get_namespace (current_interface
.ns
, 0);
4000 st
= next_statement ();
4008 if (st
== ST_SUBROUTINE
)
4009 new_state
= COMP_SUBROUTINE
;
4010 else if (st
== ST_FUNCTION
)
4011 new_state
= COMP_FUNCTION
;
4012 if (gfc_new_block
->attr
.pointer
)
4014 gfc_new_block
->attr
.pointer
= 0;
4015 gfc_new_block
->attr
.proc_pointer
= 1;
4017 if (!gfc_add_explicit_interface (gfc_new_block
, IFSRC_IFBODY
,
4018 gfc_new_block
->formal
, NULL
))
4020 reject_statement ();
4021 gfc_free_namespace (gfc_current_ns
);
4024 /* F2008 C1210 forbids the IMPORT statement in module procedure
4025 interface bodies and the flag is set to import symbols. */
4026 if (gfc_new_block
->attr
.module_procedure
)
4027 gfc_current_ns
->has_import_set
= 1;
4031 case ST_MODULE_PROC
: /* The module procedure matcher makes
4032 sure the context is correct. */
4033 accept_statement (st
);
4034 gfc_free_namespace (gfc_current_ns
);
4037 case ST_END_INTERFACE
:
4038 gfc_free_namespace (gfc_current_ns
);
4039 gfc_current_ns
= current_interface
.ns
;
4043 gfc_error ("Unexpected %s statement in INTERFACE block at %C",
4044 gfc_ascii_statement (st
));
4045 current_interface
= save
;
4046 reject_statement ();
4047 gfc_free_namespace (gfc_current_ns
);
4052 /* Make sure that the generic name has the right attribute. */
4053 if (current_interface
.type
== INTERFACE_GENERIC
4054 && current_state
== COMP_NONE
)
4056 if (new_state
== COMP_FUNCTION
&& sym
)
4057 gfc_add_function (&sym
->attr
, sym
->name
, NULL
);
4058 else if (new_state
== COMP_SUBROUTINE
&& sym
)
4059 gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
);
4061 current_state
= new_state
;
4064 if (current_interface
.type
== INTERFACE_ABSTRACT
)
4066 gfc_add_abstract (&gfc_new_block
->attr
, &gfc_current_locus
);
4067 if (gfc_is_intrinsic_typename (gfc_new_block
->name
))
4068 gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
4069 "cannot be the same as an intrinsic type",
4070 gfc_new_block
->name
);
4073 push_state (&s2
, new_state
, gfc_new_block
);
4074 accept_statement (st
);
4075 prog_unit
= gfc_new_block
;
4076 prog_unit
->formal_ns
= gfc_current_ns
;
4079 /* Read data declaration statements. */
4080 st
= parse_spec (ST_NONE
);
4081 in_specification_block
= true;
4083 /* Since the interface block does not permit an IMPLICIT statement,
4084 the default type for the function or the result must be taken
4085 from the formal namespace. */
4086 if (new_state
== COMP_FUNCTION
)
4088 if (prog_unit
->result
== prog_unit
4089 && prog_unit
->ts
.type
== BT_UNKNOWN
)
4090 gfc_set_default_type (prog_unit
, 1, prog_unit
->formal_ns
);
4091 else if (prog_unit
->result
!= prog_unit
4092 && prog_unit
->result
->ts
.type
== BT_UNKNOWN
)
4093 gfc_set_default_type (prog_unit
->result
, 1,
4094 prog_unit
->formal_ns
);
4097 if (st
!= ST_END_SUBROUTINE
&& st
!= ST_END_FUNCTION
)
4099 gfc_error ("Unexpected %s statement at %C in INTERFACE body",
4100 gfc_ascii_statement (st
));
4101 reject_statement ();
4105 /* Add EXTERNAL attribute to function or subroutine. */
4106 if (current_interface
.type
!= INTERFACE_ABSTRACT
&& !prog_unit
->attr
.dummy
)
4107 gfc_add_external (&prog_unit
->attr
, &gfc_current_locus
);
4109 current_interface
= save
;
4110 gfc_add_interface (prog_unit
);
4113 if (current_interface
.ns
4114 && current_interface
.ns
->proc_name
4115 && strcmp (current_interface
.ns
->proc_name
->name
,
4116 prog_unit
->name
) == 0)
4117 gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
4118 "enclosing procedure", prog_unit
->name
,
4119 ¤t_interface
.ns
->proc_name
->declared_at
);
4128 /* Associate function characteristics by going back to the function
4129 declaration and rematching the prefix. */
4132 match_deferred_characteristics (gfc_typespec
* ts
)
4135 match m
= MATCH_ERROR
;
4136 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
4138 loc
= gfc_current_locus
;
4140 gfc_current_locus
= gfc_current_block ()->declared_at
;
4143 gfc_buffer_error (true);
4144 m
= gfc_match_prefix (ts
);
4145 gfc_buffer_error (false);
4147 if (ts
->type
== BT_DERIVED
|| ts
->type
== BT_CLASS
)
4155 /* Only permit one go at the characteristic association. */
4159 /* Set the function locus correctly. If we have not found the
4160 function name, there is an error. */
4162 && gfc_match ("function% %n", name
) == MATCH_YES
4163 && strcmp (name
, gfc_current_block ()->name
) == 0)
4165 gfc_current_block ()->declared_at
= gfc_current_locus
;
4166 gfc_commit_symbols ();
4171 gfc_undo_symbols ();
4174 gfc_current_locus
=loc
;
4179 /* Check specification-expressions in the function result of the currently
4180 parsed block and ensure they are typed (give an IMPLICIT type if necessary).
4181 For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
4182 scope are not yet parsed so this has to be delayed up to parse_spec. */
4185 check_function_result_typed (void)
4189 gcc_assert (gfc_current_state () == COMP_FUNCTION
);
4191 if (!gfc_current_ns
->proc_name
->result
)
4194 ts
= gfc_current_ns
->proc_name
->result
->ts
;
4196 /* Check type-parameters, at the moment only CHARACTER lengths possible. */
4197 /* TODO: Extend when KIND type parameters are implemented. */
4198 if (ts
.type
== BT_CHARACTER
&& ts
.u
.cl
&& ts
.u
.cl
->length
)
4200 /* Reject invalid type of specification expression for length. */
4201 if (ts
.u
.cl
->length
->ts
.type
!= BT_INTEGER
)
4204 gfc_expr_check_typed (ts
.u
.cl
->length
, gfc_current_ns
, true);
4211 /* Parse a set of specification statements. Returns the statement
4212 that doesn't fit. */
4214 static gfc_statement
4215 parse_spec (gfc_statement st
)
4218 bool function_result_typed
= false;
4219 bool bad_characteristic
= false;
4222 in_specification_block
= true;
4224 verify_st_order (&ss
, ST_NONE
, false);
4226 st
= next_statement ();
4228 /* If we are not inside a function or don't have a result specified so far,
4229 do nothing special about it. */
4230 if (gfc_current_state () != COMP_FUNCTION
)
4231 function_result_typed
= true;
4234 gfc_symbol
* proc
= gfc_current_ns
->proc_name
;
4237 if (proc
->result
&& proc
->result
->ts
.type
== BT_UNKNOWN
)
4238 function_result_typed
= true;
4243 /* If we're inside a BLOCK construct, some statements are disallowed.
4244 Check this here. Attribute declaration statements like INTENT, OPTIONAL
4245 or VALUE are also disallowed, but they don't have a particular ST_*
4246 key so we have to check for them individually in their matcher routine. */
4247 if (gfc_current_state () == COMP_BLOCK
)
4251 case ST_IMPLICIT_NONE
:
4254 case ST_EQUIVALENCE
:
4255 case ST_STATEMENT_FUNCTION
:
4256 gfc_error ("%s statement is not allowed inside of BLOCK at %C",
4257 gfc_ascii_statement (st
));
4258 reject_statement ();
4264 else if (gfc_current_state () == COMP_BLOCK_DATA
)
4265 /* Fortran 2008, C1116. */
4272 case ST_DERIVED_DECL
:
4273 case ST_END_BLOCK_DATA
:
4274 case ST_EQUIVALENCE
:
4276 case ST_IMPLICIT_NONE
:
4277 case ST_OMP_THREADPRIVATE
:
4279 case ST_STRUCTURE_DECL
:
4288 gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
4289 gfc_ascii_statement (st
));
4290 reject_statement ();
4294 /* If we find a statement that cannot be followed by an IMPLICIT statement
4295 (and thus we can expect to see none any further), type the function result
4296 if it has not yet been typed. Be careful not to give the END statement
4297 to verify_st_order! */
4298 if (!function_result_typed
&& st
!= ST_GET_FCN_CHARACTERISTICS
)
4300 bool verify_now
= false;
4302 if (st
== ST_END_FUNCTION
|| st
== ST_CONTAINS
)
4307 verify_st_order (&dummyss
, ST_NONE
, false);
4308 verify_st_order (&dummyss
, st
, false);
4310 if (!verify_st_order (&dummyss
, ST_IMPLICIT
, true))
4315 function_result_typed
= check_function_result_typed ();
4323 case ST_IMPLICIT_NONE
:
4325 if (!function_result_typed
)
4326 function_result_typed
= check_function_result_typed ();
4331 case ST_DATA
: /* Not allowed in interfaces */
4332 if (gfc_current_state () == COMP_INTERFACE
)
4342 case ST_STRUCTURE_DECL
:
4343 case ST_DERIVED_DECL
:
4347 if (!verify_st_order (&ss
, st
, false))
4349 reject_statement ();
4350 st
= next_statement ();
4360 case ST_STRUCTURE_DECL
:
4361 parse_struct_map (ST_STRUCTURE_DECL
);
4364 case ST_DERIVED_DECL
:
4370 if (gfc_current_state () != COMP_MODULE
)
4372 gfc_error ("%s statement must appear in a MODULE",
4373 gfc_ascii_statement (st
));
4374 reject_statement ();
4378 if (gfc_current_ns
->default_access
!= ACCESS_UNKNOWN
)
4380 gfc_error ("%s statement at %C follows another accessibility "
4381 "specification", gfc_ascii_statement (st
));
4382 reject_statement ();
4386 gfc_current_ns
->default_access
= (st
== ST_PUBLIC
)
4387 ? ACCESS_PUBLIC
: ACCESS_PRIVATE
;
4391 case ST_STATEMENT_FUNCTION
:
4392 if (gfc_current_state () == COMP_MODULE
4393 || gfc_current_state () == COMP_SUBMODULE
)
4395 unexpected_statement (st
);
4403 accept_statement (st
);
4404 st
= next_statement ();
4408 accept_statement (st
);
4410 st
= next_statement ();
4413 case ST_GET_FCN_CHARACTERISTICS
:
4414 /* This statement triggers the association of a function's result
4416 ts
= &gfc_current_block ()->result
->ts
;
4417 if (match_deferred_characteristics (ts
) != MATCH_YES
)
4418 bad_characteristic
= true;
4420 st
= next_statement ();
4427 /* If match_deferred_characteristics failed, then there is an error. */
4428 if (bad_characteristic
)
4430 ts
= &gfc_current_block ()->result
->ts
;
4431 if (ts
->type
!= BT_DERIVED
&& ts
->type
!= BT_CLASS
)
4432 gfc_error ("Bad kind expression for function %qs at %L",
4433 gfc_current_block ()->name
,
4434 &gfc_current_block ()->declared_at
);
4436 gfc_error ("The type for function %qs at %L is not accessible",
4437 gfc_current_block ()->name
,
4438 &gfc_current_block ()->declared_at
);
4440 gfc_current_block ()->ts
.kind
= 0;
4441 /* Keep the derived type; if it's bad, it will be discovered later. */
4442 if (!(ts
->type
== BT_DERIVED
&& ts
->u
.derived
))
4443 ts
->type
= BT_UNKNOWN
;
4446 in_specification_block
= false;
4452 /* Parse a WHERE block, (not a simple WHERE statement). */
4455 parse_where_block (void)
4457 int seen_empty_else
;
4462 accept_statement (ST_WHERE_BLOCK
);
4463 top
= gfc_state_stack
->tail
;
4465 push_state (&s
, COMP_WHERE
, gfc_new_block
);
4467 d
= add_statement ();
4468 d
->expr1
= top
->expr1
;
4474 seen_empty_else
= 0;
4478 st
= next_statement ();
4484 case ST_WHERE_BLOCK
:
4485 parse_where_block ();
4490 accept_statement (st
);
4494 if (seen_empty_else
)
4496 gfc_error ("ELSEWHERE statement at %C follows previous "
4497 "unmasked ELSEWHERE");
4498 reject_statement ();
4502 if (new_st
.expr1
== NULL
)
4503 seen_empty_else
= 1;
4505 d
= new_level (gfc_state_stack
->head
);
4507 d
->expr1
= new_st
.expr1
;
4509 accept_statement (st
);
4514 accept_statement (st
);
4518 gfc_error ("Unexpected %s statement in WHERE block at %C",
4519 gfc_ascii_statement (st
));
4520 reject_statement ();
4524 while (st
!= ST_END_WHERE
);
4530 /* Parse a FORALL block (not a simple FORALL statement). */
4533 parse_forall_block (void)
4539 accept_statement (ST_FORALL_BLOCK
);
4540 top
= gfc_state_stack
->tail
;
4542 push_state (&s
, COMP_FORALL
, gfc_new_block
);
4544 d
= add_statement ();
4545 d
->op
= EXEC_FORALL
;
4550 st
= next_statement ();
4555 case ST_POINTER_ASSIGNMENT
:
4558 accept_statement (st
);
4561 case ST_WHERE_BLOCK
:
4562 parse_where_block ();
4565 case ST_FORALL_BLOCK
:
4566 parse_forall_block ();
4570 accept_statement (st
);
4577 gfc_error ("Unexpected %s statement in FORALL block at %C",
4578 gfc_ascii_statement (st
));
4580 reject_statement ();
4584 while (st
!= ST_END_FORALL
);
4590 static gfc_statement
parse_executable (gfc_statement
);
4592 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block. */
4595 parse_if_block (void)
4604 accept_statement (ST_IF_BLOCK
);
4606 top
= gfc_state_stack
->tail
;
4607 push_state (&s
, COMP_IF
, gfc_new_block
);
4609 new_st
.op
= EXEC_IF
;
4610 d
= add_statement ();
4612 d
->expr1
= top
->expr1
;
4618 st
= parse_executable (ST_NONE
);
4628 gfc_error ("ELSE IF statement at %C cannot follow ELSE "
4629 "statement at %L", &else_locus
);
4631 reject_statement ();
4635 d
= new_level (gfc_state_stack
->head
);
4637 d
->expr1
= new_st
.expr1
;
4639 accept_statement (st
);
4646 gfc_error ("Duplicate ELSE statements at %L and %C",
4648 reject_statement ();
4653 else_locus
= gfc_current_locus
;
4655 d
= new_level (gfc_state_stack
->head
);
4658 accept_statement (st
);
4666 unexpected_statement (st
);
4670 while (st
!= ST_ENDIF
);
4673 accept_statement (st
);
4677 /* Parse a SELECT block. */
4680 parse_select_block (void)
4686 accept_statement (ST_SELECT_CASE
);
4688 cp
= gfc_state_stack
->tail
;
4689 push_state (&s
, COMP_SELECT
, gfc_new_block
);
4691 /* Make sure that the next statement is a CASE or END SELECT. */
4694 st
= next_statement ();
4697 if (st
== ST_END_SELECT
)
4699 /* Empty SELECT CASE is OK. */
4700 accept_statement (st
);
4707 gfc_error ("Expected a CASE or END SELECT statement following SELECT "
4710 reject_statement ();
4713 /* At this point, we've got a nonempty select block. */
4714 cp
= new_level (cp
);
4717 accept_statement (st
);
4721 st
= parse_executable (ST_NONE
);
4728 cp
= new_level (gfc_state_stack
->head
);
4730 gfc_clear_new_st ();
4732 accept_statement (st
);
4738 /* Can't have an executable statement because of
4739 parse_executable(). */
4741 unexpected_statement (st
);
4745 while (st
!= ST_END_SELECT
);
4748 accept_statement (st
);
4752 /* Pop the current selector from the SELECT TYPE stack. */
4755 select_type_pop (void)
4757 gfc_select_type_stack
*old
= select_type_stack
;
4758 select_type_stack
= old
->prev
;
4763 /* Parse a SELECT TYPE construct (F03:R821). */
4766 parse_select_type_block (void)
4772 gfc_current_ns
= new_st
.ext
.block
.ns
;
4773 accept_statement (ST_SELECT_TYPE
);
4775 cp
= gfc_state_stack
->tail
;
4776 push_state (&s
, COMP_SELECT_TYPE
, gfc_new_block
);
4778 /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
4782 st
= next_statement ();
4785 if (st
== ST_END_SELECT
)
4786 /* Empty SELECT CASE is OK. */
4788 if (st
== ST_TYPE_IS
|| st
== ST_CLASS_IS
)
4791 gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
4792 "following SELECT TYPE at %C");
4794 reject_statement ();
4797 /* At this point, we've got a nonempty select block. */
4798 cp
= new_level (cp
);
4801 accept_statement (st
);
4805 st
= parse_executable (ST_NONE
);
4813 cp
= new_level (gfc_state_stack
->head
);
4815 gfc_clear_new_st ();
4817 accept_statement (st
);
4823 /* Can't have an executable statement because of
4824 parse_executable(). */
4826 unexpected_statement (st
);
4830 while (st
!= ST_END_SELECT
);
4834 accept_statement (st
);
4835 gfc_current_ns
= gfc_current_ns
->parent
;
4840 /* Parse a SELECT RANK construct. */
4843 parse_select_rank_block (void)
4849 gfc_current_ns
= new_st
.ext
.block
.ns
;
4850 accept_statement (ST_SELECT_RANK
);
4852 cp
= gfc_state_stack
->tail
;
4853 push_state (&s
, COMP_SELECT_RANK
, gfc_new_block
);
4855 /* Make sure that the next statement is a RANK IS or RANK DEFAULT. */
4858 st
= next_statement ();
4861 if (st
== ST_END_SELECT
)
4862 /* Empty SELECT CASE is OK. */
4867 gfc_error ("Expected RANK or RANK DEFAULT "
4868 "following SELECT RANK at %C");
4870 reject_statement ();
4873 /* At this point, we've got a nonempty select block. */
4874 cp
= new_level (cp
);
4877 accept_statement (st
);
4881 st
= parse_executable (ST_NONE
);
4888 cp
= new_level (gfc_state_stack
->head
);
4890 gfc_clear_new_st ();
4892 accept_statement (st
);
4898 /* Can't have an executable statement because of
4899 parse_executable(). */
4901 unexpected_statement (st
);
4905 while (st
!= ST_END_SELECT
);
4909 accept_statement (st
);
4910 gfc_current_ns
= gfc_current_ns
->parent
;
4915 /* Given a symbol, make sure it is not an iteration variable for a DO
4916 statement. This subroutine is called when the symbol is seen in a
4917 context that causes it to become redefined. If the symbol is an
4918 iterator, we generate an error message and return nonzero. */
4921 gfc_check_do_variable (gfc_symtree
*st
)
4928 for (s
=gfc_state_stack
; s
; s
= s
->previous
)
4929 if (s
->do_variable
== st
)
4931 gfc_error_now ("Variable %qs at %C cannot be redefined inside "
4932 "loop beginning at %L", st
->name
, &s
->head
->loc
);
4940 /* Checks to see if the current statement label closes an enddo.
4941 Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
4942 an error) if it incorrectly closes an ENDDO. */
4945 check_do_closure (void)
4949 if (gfc_statement_label
== NULL
)
4952 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
4953 if (p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4957 return 0; /* No loops to close */
4959 if (p
->ext
.end_do_label
== gfc_statement_label
)
4961 if (p
== gfc_state_stack
)
4964 gfc_error ("End of nonblock DO statement at %C is within another block");
4968 /* At this point, the label doesn't terminate the innermost loop.
4969 Make sure it doesn't terminate another one. */
4970 for (; p
; p
= p
->previous
)
4971 if ((p
->state
== COMP_DO
|| p
->state
== COMP_DO_CONCURRENT
)
4972 && p
->ext
.end_do_label
== gfc_statement_label
)
4974 gfc_error ("End of nonblock DO statement at %C is interwoven "
4975 "with another DO loop");
4983 /* Parse a series of contained program units. */
4985 static void parse_progunit (gfc_statement
);
4988 /* Parse a CRITICAL block. */
4991 parse_critical_block (void)
4994 gfc_state_data s
, *sd
;
4997 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
4998 if (sd
->state
== COMP_OMP_STRUCTURED_BLOCK
)
4999 gfc_error_now (is_oacc (sd
)
5000 ? G_("CRITICAL block inside of OpenACC region at %C")
5001 : G_("CRITICAL block inside of OpenMP region at %C"));
5003 s
.ext
.end_do_label
= new_st
.label1
;
5005 accept_statement (ST_CRITICAL
);
5006 top
= gfc_state_stack
->tail
;
5008 push_state (&s
, COMP_CRITICAL
, gfc_new_block
);
5010 d
= add_statement ();
5011 d
->op
= EXEC_CRITICAL
;
5016 st
= parse_executable (ST_NONE
);
5024 case ST_END_CRITICAL
:
5025 if (s
.ext
.end_do_label
!= NULL
5026 && s
.ext
.end_do_label
!= gfc_statement_label
)
5027 gfc_error_now ("Statement label in END CRITICAL at %C does not "
5028 "match CRITICAL label");
5030 if (gfc_statement_label
!= NULL
)
5032 new_st
.op
= EXEC_NOP
;
5038 unexpected_statement (st
);
5042 while (st
!= ST_END_CRITICAL
);
5045 accept_statement (st
);
5049 /* Set up the local namespace for a BLOCK construct. */
5052 gfc_build_block_ns (gfc_namespace
*parent_ns
)
5054 gfc_namespace
* my_ns
;
5055 static int numblock
= 1;
5057 my_ns
= gfc_get_namespace (parent_ns
, 1);
5058 my_ns
->construct_entities
= 1;
5060 /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
5061 code generation (so it must not be NULL).
5062 We set its recursive argument if our container procedure is recursive, so
5063 that local variables are accordingly placed on the stack when it
5064 will be necessary. */
5066 my_ns
->proc_name
= gfc_new_block
;
5070 char buffer
[20]; /* Enough to hold "block@2147483648\n". */
5072 snprintf(buffer
, sizeof(buffer
), "block@%d", numblock
++);
5073 gfc_get_symbol (buffer
, my_ns
, &my_ns
->proc_name
);
5074 t
= gfc_add_flavor (&my_ns
->proc_name
->attr
, FL_LABEL
,
5075 my_ns
->proc_name
->name
, NULL
);
5077 gfc_commit_symbol (my_ns
->proc_name
);
5080 if (parent_ns
->proc_name
)
5081 my_ns
->proc_name
->attr
.recursive
= parent_ns
->proc_name
->attr
.recursive
;
5087 /* Parse a BLOCK construct. */
5090 parse_block_construct (void)
5092 gfc_namespace
* my_ns
;
5093 gfc_namespace
* my_parent
;
5096 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
5098 my_ns
= gfc_build_block_ns (gfc_current_ns
);
5100 new_st
.op
= EXEC_BLOCK
;
5101 new_st
.ext
.block
.ns
= my_ns
;
5102 new_st
.ext
.block
.assoc
= NULL
;
5103 accept_statement (ST_BLOCK
);
5105 push_state (&s
, COMP_BLOCK
, my_ns
->proc_name
);
5106 gfc_current_ns
= my_ns
;
5107 my_parent
= my_ns
->parent
;
5109 parse_progunit (ST_NONE
);
5111 /* Don't depend on the value of gfc_current_ns; it might have been
5112 reset if the block had errors and was cleaned up. */
5113 gfc_current_ns
= my_parent
;
5119 /* Parse an ASSOCIATE construct. This is essentially a BLOCK construct
5120 behind the scenes with compiler-generated variables. */
5123 parse_associate (void)
5125 gfc_namespace
* my_ns
;
5128 gfc_association_list
* a
;
5131 gfc_notify_std (GFC_STD_F2003
, "ASSOCIATE construct at %C");
5133 my_ns
= gfc_build_block_ns (gfc_current_ns
);
5135 new_st
.op
= EXEC_BLOCK
;
5136 new_st
.ext
.block
.ns
= my_ns
;
5137 gcc_assert (new_st
.ext
.block
.assoc
);
5139 /* Add all associate-names as BLOCK variables. Creating them is enough
5140 for now, they'll get their values during trans-* phase. */
5141 gfc_current_ns
= my_ns
;
5142 for (a
= new_st
.ext
.block
.assoc
; a
; a
= a
->next
)
5144 gfc_symbol
*sym
, *tsym
;
5148 if (gfc_get_sym_tree (a
->name
, NULL
, &a
->st
, false))
5152 sym
->attr
.flavor
= FL_VARIABLE
;
5154 sym
->declared_at
= a
->where
;
5155 gfc_set_sym_referenced (sym
);
5157 /* If the selector is a inferred type then the associate_name had better
5158 be as well. Use array references, if present, to identify it as an
5160 if (IS_INFERRED_TYPE (a
->target
))
5162 sym
->assoc
->inferred_type
= 1;
5163 for (gfc_ref
*r
= a
->target
->ref
; r
; r
= r
->next
)
5164 if (r
->type
== REF_ARRAY
)
5165 sym
->attr
.dimension
= 1;
5168 /* Initialize the typespec. It is not available in all cases,
5169 however, as it may only be set on the target during resolution.
5170 Still, sometimes it helps to have it right now -- especially
5171 for parsing component references on the associate-name
5172 in case of association to a derived-type. */
5173 sym
->ts
= a
->target
->ts
;
5176 /* Don’t share the character length information between associate
5177 variable and target if the length is not a compile-time constant,
5178 as we don’t want to touch some other character length variable when
5179 we try to initialize the associate variable’s character length
5181 We do it here rather than later so that expressions referencing the
5182 associate variable will automatically have the correctly setup length
5183 information. If we did it at resolution stage the expressions would
5184 use the original length information, and the variable a new different
5185 one, but only the latter one would be correctly initialized at
5186 translation stage, and the former one would need some additional setup
5188 if (sym
->ts
.type
== BT_CHARACTER
5190 && !(sym
->ts
.u
.cl
->length
5191 && sym
->ts
.u
.cl
->length
->expr_type
== EXPR_CONSTANT
))
5192 sym
->ts
.u
.cl
= gfc_new_charlen (gfc_current_ns
, NULL
);
5194 /* If the function has been parsed, go straight to the result to
5195 obtain the expression rank. */
5196 if (target
->expr_type
== EXPR_FUNCTION
5198 && target
->symtree
->n
.sym
)
5200 tsym
= target
->symtree
->n
.sym
;
5202 tsym
->result
= tsym
;
5203 sym
->ts
= tsym
->result
->ts
;
5204 if (sym
->ts
.type
== BT_CLASS
)
5206 if (CLASS_DATA (sym
)->as
)
5207 target
->rank
= CLASS_DATA (sym
)->as
->rank
;
5208 sym
->attr
.class_ok
= 1;
5211 target
->rank
= tsym
->result
->as
? tsym
->result
->as
->rank
: 0;
5214 /* Check if the target expression is array valued. This cannot be done
5215 by calling gfc_resolve_expr because the context is unavailable.
5216 However, the references can be resolved and the rank of the target
5218 if (!sym
->assoc
->inferred_type
5219 && target
->ref
&& gfc_resolve_ref (target
)
5220 && target
->expr_type
!= EXPR_ARRAY
5221 && target
->expr_type
!= EXPR_COMPCALL
)
5222 gfc_expression_rank (target
);
5224 /* Determine whether or not function expressions with unknown type are
5225 structure constructors. If so, the function result can be converted
5226 to be a derived type. */
5227 if (target
->expr_type
== EXPR_FUNCTION
5228 && target
->ts
.type
== BT_UNKNOWN
)
5230 gfc_symbol
*derived
;
5231 /* The derived type has a leading uppercase character. */
5232 gfc_find_symbol (gfc_dt_upper_string (target
->symtree
->name
),
5233 my_ns
->parent
, 1, &derived
);
5234 if (derived
&& derived
->attr
.flavor
== FL_DERIVED
)
5236 sym
->ts
.type
= BT_DERIVED
;
5237 sym
->ts
.u
.derived
= derived
;
5238 sym
->assoc
->inferred_type
= 0;
5242 rank
= target
->rank
;
5243 /* Fixup cases where the ranks are mismatched. */
5244 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
))
5246 if ((!CLASS_DATA (sym
)->as
&& rank
!= 0)
5247 || (CLASS_DATA (sym
)->as
5248 && CLASS_DATA (sym
)->as
->rank
!= rank
))
5250 /* Don't just (re-)set the attr and as in the sym.ts,
5251 because this modifies the target's attr and as. Copy the
5252 data and do a build_class_symbol. */
5253 symbol_attribute attr
= CLASS_DATA (target
)->attr
;
5254 int corank
= gfc_get_corank (target
);
5259 as
= gfc_get_array_spec ();
5260 as
->type
= AS_DEFERRED
;
5262 as
->corank
= corank
;
5263 attr
.dimension
= rank
? 1 : 0;
5264 attr
.codimension
= corank
? 1 : 0;
5269 attr
.dimension
= attr
.codimension
= 0;
5272 type
= CLASS_DATA (sym
)->ts
;
5273 if (!gfc_build_class_symbol (&type
, &attr
, &as
))
5276 sym
->ts
.type
= BT_CLASS
;
5277 sym
->attr
.class_ok
= 1;
5280 sym
->attr
.class_ok
= 1;
5282 else if ((!sym
->as
&& rank
!= 0)
5283 || (sym
->as
&& sym
->as
->rank
!= rank
))
5285 as
= gfc_get_array_spec ();
5286 as
->type
= AS_DEFERRED
;
5288 as
->corank
= gfc_get_corank (target
);
5290 sym
->attr
.dimension
= 1;
5292 sym
->attr
.codimension
= 1;
5296 accept_statement (ST_ASSOCIATE
);
5297 push_state (&s
, COMP_ASSOCIATE
, my_ns
->proc_name
);
5300 st
= parse_executable (ST_NONE
);
5307 accept_statement (st
);
5308 my_ns
->code
= gfc_state_stack
->head
;
5312 unexpected_statement (st
);
5316 gfc_current_ns
= gfc_current_ns
->parent
;
5321 /* Parse a DO loop. Note that the ST_CYCLE and ST_EXIT statements are
5322 handled inside of parse_executable(), because they aren't really
5326 parse_do_block (void)
5335 s
.ext
.end_do_label
= new_st
.label1
;
5337 if (do_op
== EXEC_DO_CONCURRENT
)
5339 gfc_forall_iterator
*fa
;
5340 for (fa
= new_st
.ext
.forall_iterator
; fa
; fa
= fa
->next
)
5342 /* Apply unroll only to innermost loop (first control
5344 if (directive_unroll
!= -1)
5346 fa
->annot
.unroll
= directive_unroll
;
5347 directive_unroll
= -1;
5349 if (directive_ivdep
)
5350 fa
->annot
.ivdep
= directive_ivdep
;
5351 if (directive_vector
)
5352 fa
->annot
.vector
= directive_vector
;
5353 if (directive_novector
)
5354 fa
->annot
.novector
= directive_novector
;
5356 directive_ivdep
= false;
5357 directive_vector
= false;
5358 directive_novector
= false;
5361 else if (new_st
.ext
.iterator
!= NULL
)
5363 stree
= new_st
.ext
.iterator
->var
->symtree
;
5364 if (directive_unroll
!= -1)
5366 new_st
.ext
.iterator
->annot
.unroll
= directive_unroll
;
5367 directive_unroll
= -1;
5369 if (directive_ivdep
)
5371 new_st
.ext
.iterator
->annot
.ivdep
= directive_ivdep
;
5372 directive_ivdep
= false;
5374 if (directive_vector
)
5376 new_st
.ext
.iterator
->annot
.vector
= directive_vector
;
5377 directive_vector
= false;
5379 if (directive_novector
)
5381 new_st
.ext
.iterator
->annot
.novector
= directive_novector
;
5382 directive_novector
= false;
5388 accept_statement (ST_DO
);
5390 top
= gfc_state_stack
->tail
;
5391 push_state (&s
, do_op
== EXEC_DO_CONCURRENT
? COMP_DO_CONCURRENT
: COMP_DO
,
5394 s
.do_variable
= stree
;
5396 top
->block
= new_level (top
);
5397 top
->block
->op
= EXEC_DO
;
5400 st
= parse_executable (ST_NONE
);
5408 if (s
.ext
.end_do_label
!= NULL
5409 && s
.ext
.end_do_label
!= gfc_statement_label
)
5410 gfc_error_now ("Statement label in ENDDO at %C doesn't match "
5413 if (gfc_statement_label
!= NULL
)
5415 new_st
.op
= EXEC_NOP
;
5420 case ST_IMPLIED_ENDDO
:
5421 /* If the do-stmt of this DO construct has a do-construct-name,
5422 the corresponding end-do must be an end-do-stmt (with a matching
5423 name, but in that case we must have seen ST_ENDDO first).
5424 We only complain about this in pedantic mode. */
5425 if (gfc_current_block () != NULL
)
5426 gfc_error_now ("Named block DO at %L requires matching ENDDO name",
5427 &gfc_current_block()->declared_at
);
5432 unexpected_statement (st
);
5437 accept_statement (st
);
5441 /* Parse the statements of OpenMP do/parallel do. */
5443 static gfc_statement
5444 parse_omp_do (gfc_statement omp_st
)
5450 accept_statement (omp_st
);
5452 cp
= gfc_state_stack
->tail
;
5453 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5454 np
= new_level (cp
);
5460 st
= next_statement ();
5463 else if (st
== ST_DO
)
5466 unexpected_statement (st
);
5470 if (gfc_statement_label
!= NULL
5471 && gfc_state_stack
->previous
!= NULL
5472 && gfc_state_stack
->previous
->state
== COMP_DO
5473 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
5481 there should be no !$OMP END DO. */
5483 return ST_IMPLIED_ENDDO
;
5486 check_do_closure ();
5489 st
= next_statement ();
5490 gfc_statement omp_end_st
= ST_OMP_END_DO
;
5493 case ST_OMP_DISTRIBUTE
: omp_end_st
= ST_OMP_END_DISTRIBUTE
; break;
5494 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
5495 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO
;
5497 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
5498 omp_end_st
= ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD
;
5500 case ST_OMP_DISTRIBUTE_SIMD
:
5501 omp_end_st
= ST_OMP_END_DISTRIBUTE_SIMD
;
5503 case ST_OMP_DO
: omp_end_st
= ST_OMP_END_DO
; break;
5504 case ST_OMP_DO_SIMD
: omp_end_st
= ST_OMP_END_DO_SIMD
; break;
5505 case ST_OMP_LOOP
: omp_end_st
= ST_OMP_END_LOOP
; break;
5506 case ST_OMP_PARALLEL_DO
: omp_end_st
= ST_OMP_END_PARALLEL_DO
; break;
5507 case ST_OMP_PARALLEL_DO_SIMD
:
5508 omp_end_st
= ST_OMP_END_PARALLEL_DO_SIMD
;
5510 case ST_OMP_PARALLEL_LOOP
:
5511 omp_end_st
= ST_OMP_END_PARALLEL_LOOP
;
5513 case ST_OMP_SIMD
: omp_end_st
= ST_OMP_END_SIMD
; break;
5514 case ST_OMP_TARGET_PARALLEL_DO
:
5515 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO
;
5517 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
5518 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_DO_SIMD
;
5520 case ST_OMP_TARGET_PARALLEL_LOOP
:
5521 omp_end_st
= ST_OMP_END_TARGET_PARALLEL_LOOP
;
5523 case ST_OMP_TARGET_SIMD
: omp_end_st
= ST_OMP_END_TARGET_SIMD
; break;
5524 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
5525 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE
;
5527 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5528 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5530 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5531 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5533 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
5534 omp_end_st
= ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD
;
5536 case ST_OMP_TARGET_TEAMS_LOOP
:
5537 omp_end_st
= ST_OMP_END_TARGET_TEAMS_LOOP
;
5539 case ST_OMP_TASKLOOP
: omp_end_st
= ST_OMP_END_TASKLOOP
; break;
5540 case ST_OMP_TASKLOOP_SIMD
: omp_end_st
= ST_OMP_END_TASKLOOP_SIMD
; break;
5541 case ST_OMP_MASKED_TASKLOOP
: omp_end_st
= ST_OMP_END_MASKED_TASKLOOP
; break;
5542 case ST_OMP_MASKED_TASKLOOP_SIMD
:
5543 omp_end_st
= ST_OMP_END_MASKED_TASKLOOP_SIMD
;
5545 case ST_OMP_MASTER_TASKLOOP
: omp_end_st
= ST_OMP_END_MASTER_TASKLOOP
; break;
5546 case ST_OMP_MASTER_TASKLOOP_SIMD
:
5547 omp_end_st
= ST_OMP_END_MASTER_TASKLOOP_SIMD
;
5549 case ST_OMP_PARALLEL_MASKED_TASKLOOP
:
5550 omp_end_st
= ST_OMP_END_PARALLEL_MASKED_TASKLOOP
;
5552 case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
5553 omp_end_st
= ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD
;
5555 case ST_OMP_PARALLEL_MASTER_TASKLOOP
:
5556 omp_end_st
= ST_OMP_END_PARALLEL_MASTER_TASKLOOP
;
5558 case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
5559 omp_end_st
= ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD
;
5561 case ST_OMP_TEAMS_DISTRIBUTE
:
5562 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
5564 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
5565 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO
;
5567 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
5568 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
;
5570 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
5571 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE_SIMD
;
5573 case ST_OMP_TEAMS_LOOP
:
5574 omp_end_st
= ST_OMP_END_TEAMS_LOOP
;
5576 default: gcc_unreachable ();
5578 if (st
== omp_end_st
)
5580 if (new_st
.op
== EXEC_OMP_END_NOWAIT
)
5582 if (cp
->ext
.omp_clauses
->nowait
&& new_st
.ext
.omp_bool
)
5583 gfc_error_now ("Duplicated NOWAIT clause on %s and %s at %C",
5584 gfc_ascii_statement (omp_st
),
5585 gfc_ascii_statement (omp_end_st
));
5586 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
5589 gcc_assert (new_st
.op
== EXEC_NOP
);
5590 gfc_clear_new_st ();
5591 gfc_commit_symbols ();
5592 gfc_warning_check ();
5593 st
= next_statement ();
5599 /* Parse the statements of OpenMP atomic directive. */
5601 static gfc_statement
5602 parse_omp_oacc_atomic (bool omp_p
)
5604 gfc_statement st
, st_atomic
, st_end_atomic
;
5611 st_atomic
= ST_OMP_ATOMIC
;
5612 st_end_atomic
= ST_OMP_END_ATOMIC
;
5616 st_atomic
= ST_OACC_ATOMIC
;
5617 st_end_atomic
= ST_OACC_END_ATOMIC
;
5619 accept_statement (st_atomic
);
5621 cp
= gfc_state_stack
->tail
;
5622 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5623 np
= new_level (cp
);
5626 np
->ext
.omp_clauses
= cp
->ext
.omp_clauses
;
5627 cp
->ext
.omp_clauses
= NULL
;
5628 count
= 1 + np
->ext
.omp_clauses
->capture
;
5632 st
= next_statement ();
5635 else if (np
->ext
.omp_clauses
->compare
5636 && (st
== ST_SIMPLE_IF
|| st
== ST_IF_BLOCK
))
5639 if (st
== ST_IF_BLOCK
)
5642 /* With else (or elseif). */
5643 if (gfc_state_stack
->tail
->block
->block
)
5646 accept_statement (st
);
5648 else if (st
== ST_ASSIGNMENT
5649 && (!np
->ext
.omp_clauses
->compare
5650 || np
->ext
.omp_clauses
->capture
))
5652 accept_statement (st
);
5656 unexpected_statement (st
);
5661 st
= next_statement ();
5662 if (st
== st_end_atomic
)
5664 gfc_clear_new_st ();
5665 gfc_commit_symbols ();
5666 gfc_warning_check ();
5667 st
= next_statement ();
5673 /* Parse the statements of an OpenACC structured block. */
5676 parse_oacc_structured_block (gfc_statement acc_st
)
5678 gfc_statement st
, acc_end_st
;
5680 gfc_state_data s
, *sd
;
5682 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
5683 if (sd
->state
== COMP_CRITICAL
)
5684 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5686 accept_statement (acc_st
);
5688 cp
= gfc_state_stack
->tail
;
5689 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5690 np
= new_level (cp
);
5695 case ST_OACC_PARALLEL
:
5696 acc_end_st
= ST_OACC_END_PARALLEL
;
5698 case ST_OACC_KERNELS
:
5699 acc_end_st
= ST_OACC_END_KERNELS
;
5701 case ST_OACC_SERIAL
:
5702 acc_end_st
= ST_OACC_END_SERIAL
;
5705 acc_end_st
= ST_OACC_END_DATA
;
5707 case ST_OACC_HOST_DATA
:
5708 acc_end_st
= ST_OACC_END_HOST_DATA
;
5716 st
= parse_executable (ST_NONE
);
5719 else if (st
!= acc_end_st
)
5721 gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st
));
5722 reject_statement ();
5725 while (st
!= acc_end_st
);
5727 gcc_assert (new_st
.op
== EXEC_NOP
);
5729 gfc_clear_new_st ();
5730 gfc_commit_symbols ();
5731 gfc_warning_check ();
5735 /* Parse the statements of OpenACC 'loop', or combined compute 'loop'. */
5737 static gfc_statement
5738 parse_oacc_loop (gfc_statement acc_st
)
5742 gfc_state_data s
, *sd
;
5744 for (sd
= gfc_state_stack
; sd
; sd
= sd
->previous
)
5745 if (sd
->state
== COMP_CRITICAL
)
5746 gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5748 accept_statement (acc_st
);
5750 cp
= gfc_state_stack
->tail
;
5751 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5752 np
= new_level (cp
);
5758 st
= next_statement ();
5761 else if (st
== ST_DO
)
5765 gfc_error ("Expected DO loop at %C");
5766 reject_statement ();
5771 if (gfc_statement_label
!= NULL
5772 && gfc_state_stack
->previous
!= NULL
5773 && gfc_state_stack
->previous
->state
== COMP_DO
5774 && gfc_state_stack
->previous
->ext
.end_do_label
== gfc_statement_label
)
5777 return ST_IMPLIED_ENDDO
;
5780 check_do_closure ();
5783 st
= next_statement ();
5784 if (st
== ST_OACC_END_LOOP
)
5785 gfc_warning (0, "Redundant !$ACC END LOOP at %C");
5786 if ((acc_st
== ST_OACC_PARALLEL_LOOP
&& st
== ST_OACC_END_PARALLEL_LOOP
) ||
5787 (acc_st
== ST_OACC_KERNELS_LOOP
&& st
== ST_OACC_END_KERNELS_LOOP
) ||
5788 (acc_st
== ST_OACC_SERIAL_LOOP
&& st
== ST_OACC_END_SERIAL_LOOP
) ||
5789 (acc_st
== ST_OACC_LOOP
&& st
== ST_OACC_END_LOOP
))
5791 gcc_assert (new_st
.op
== EXEC_NOP
);
5792 gfc_clear_new_st ();
5793 gfc_commit_symbols ();
5794 gfc_warning_check ();
5795 st
= next_statement ();
5801 /* Parse an OpenMP allocate block, including optional ALLOCATORS
5804 static gfc_statement
5805 parse_openmp_allocate_block (gfc_statement omp_st
)
5810 bool empty_list
= false;
5811 locus empty_list_loc
;
5812 gfc_omp_namelist
*n_first
= new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
];
5814 if (omp_st
== ST_OMP_ALLOCATE_EXEC
5815 && new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->sym
== NULL
)
5818 empty_list_loc
= new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->where
;
5821 accept_statement (omp_st
);
5823 cp
= gfc_state_stack
->tail
;
5824 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5825 np
= new_level (cp
);
5829 st
= next_statement ();
5830 while (omp_st
== ST_OMP_ALLOCATE_EXEC
&& st
== ST_OMP_ALLOCATE_EXEC
)
5832 if (empty_list
&& !new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->sym
)
5834 locus
*loc
= &new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->where
;
5835 gfc_error_now ("%s statements at %L and %L have both no list item but"
5836 " only one may", gfc_ascii_statement (st
),
5837 &empty_list_loc
, loc
);
5840 if (!new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->sym
)
5843 empty_list_loc
= new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
]->where
;
5845 for ( ; n_first
->next
; n_first
= n_first
->next
)
5847 n_first
->next
= new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
];
5848 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_ALLOCATE
] = NULL
;
5849 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
5851 accept_statement (ST_NONE
);
5852 st
= next_statement ();
5854 if (st
!= ST_ALLOCATE
&& omp_st
== ST_OMP_ALLOCATE_EXEC
)
5855 gfc_error_now ("Unexpected %s at %C; expected ALLOCATE or %s statement",
5856 gfc_ascii_statement (st
), gfc_ascii_statement (omp_st
));
5857 else if (st
!= ST_ALLOCATE
)
5858 gfc_error_now ("Unexpected %s at %C; expected ALLOCATE statement after %s",
5859 gfc_ascii_statement (st
), gfc_ascii_statement (omp_st
));
5860 accept_statement (st
);
5862 st
= next_statement ();
5863 if (omp_st
== ST_OMP_ALLOCATORS
&& st
== ST_OMP_END_ALLOCATORS
)
5865 accept_statement (st
);
5866 st
= next_statement ();
5872 /* Parse the statements of an OpenMP structured block. */
5874 static gfc_statement
5875 parse_omp_structured_block (gfc_statement omp_st
, bool workshare_stmts_only
)
5877 gfc_statement st
, omp_end_st
, first_st
;
5879 gfc_state_data s
, s2
;
5881 accept_statement (omp_st
);
5883 cp
= gfc_state_stack
->tail
;
5884 push_state (&s
, COMP_OMP_STRUCTURED_BLOCK
, NULL
);
5885 np
= new_level (cp
);
5892 omp_end_st
= ST_OMP_END_ASSUME
;
5894 case ST_OMP_PARALLEL
:
5895 omp_end_st
= ST_OMP_END_PARALLEL
;
5897 case ST_OMP_PARALLEL_MASKED
:
5898 omp_end_st
= ST_OMP_END_PARALLEL_MASKED
;
5900 case ST_OMP_PARALLEL_MASTER
:
5901 omp_end_st
= ST_OMP_END_PARALLEL_MASTER
;
5903 case ST_OMP_PARALLEL_SECTIONS
:
5904 omp_end_st
= ST_OMP_END_PARALLEL_SECTIONS
;
5907 omp_end_st
= ST_OMP_END_SCOPE
;
5909 case ST_OMP_SECTIONS
:
5910 omp_end_st
= ST_OMP_END_SECTIONS
;
5912 case ST_OMP_ORDERED
:
5913 omp_end_st
= ST_OMP_END_ORDERED
;
5915 case ST_OMP_CRITICAL
:
5916 omp_end_st
= ST_OMP_END_CRITICAL
;
5919 omp_end_st
= ST_OMP_END_MASKED
;
5922 omp_end_st
= ST_OMP_END_MASTER
;
5925 omp_end_st
= ST_OMP_END_SINGLE
;
5928 omp_end_st
= ST_OMP_END_TARGET
;
5930 case ST_OMP_TARGET_DATA
:
5931 omp_end_st
= ST_OMP_END_TARGET_DATA
;
5933 case ST_OMP_TARGET_PARALLEL
:
5934 omp_end_st
= ST_OMP_END_TARGET_PARALLEL
;
5936 case ST_OMP_TARGET_TEAMS
:
5937 omp_end_st
= ST_OMP_END_TARGET_TEAMS
;
5940 omp_end_st
= ST_OMP_END_TASK
;
5942 case ST_OMP_TASKGROUP
:
5943 omp_end_st
= ST_OMP_END_TASKGROUP
;
5946 omp_end_st
= ST_OMP_END_TEAMS
;
5948 case ST_OMP_TEAMS_DISTRIBUTE
:
5949 omp_end_st
= ST_OMP_END_TEAMS_DISTRIBUTE
;
5951 case ST_OMP_DISTRIBUTE
:
5952 omp_end_st
= ST_OMP_END_DISTRIBUTE
;
5954 case ST_OMP_WORKSHARE
:
5955 omp_end_st
= ST_OMP_END_WORKSHARE
;
5957 case ST_OMP_PARALLEL_WORKSHARE
:
5958 omp_end_st
= ST_OMP_END_PARALLEL_WORKSHARE
;
5964 bool block_construct
= false;
5965 gfc_namespace
*my_ns
= NULL
;
5966 gfc_namespace
*my_parent
= NULL
;
5968 first_st
= st
= next_statement ();
5972 /* Adjust state to a strictly-structured block, now that we found that
5973 the body starts with a BLOCK construct. */
5974 s
.state
= COMP_OMP_STRICTLY_STRUCTURED_BLOCK
;
5976 block_construct
= true;
5977 gfc_notify_std (GFC_STD_F2008
, "BLOCK construct at %C");
5979 my_ns
= gfc_build_block_ns (gfc_current_ns
);
5980 new_st
.op
= EXEC_BLOCK
;
5981 new_st
.ext
.block
.ns
= my_ns
;
5982 new_st
.ext
.block
.assoc
= NULL
;
5983 accept_statement (ST_BLOCK
);
5985 push_state (&s2
, COMP_BLOCK
, my_ns
->proc_name
);
5986 gfc_current_ns
= my_ns
;
5987 my_parent
= my_ns
->parent
;
5988 if (omp_st
== ST_OMP_SECTIONS
5989 || omp_st
== ST_OMP_PARALLEL_SECTIONS
)
5991 np
= new_level (cp
);
5995 first_st
= next_statement ();
5996 st
= parse_spec (first_st
);
5999 if (omp_end_st
== ST_OMP_END_TARGET
)
6003 case ST_OMP_TEAMS_DISTRIBUTE
:
6004 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
6005 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
6006 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
6007 case ST_OMP_TEAMS_LOOP
:
6009 gfc_state_data
*stk
= gfc_state_stack
->previous
;
6010 if (stk
->state
== COMP_OMP_STRICTLY_STRUCTURED_BLOCK
)
6011 stk
= stk
->previous
;
6012 stk
->tail
->ext
.omp_clauses
->target_first_st_is_teams
= true;
6021 if (workshare_stmts_only
)
6023 /* Inside of !$omp workshare, only
6026 where statements and constructs
6027 forall statements and constructs
6031 are allowed. For !$omp critical these
6032 restrictions apply recursively. */
6045 accept_statement (st
);
6048 case ST_WHERE_BLOCK
:
6049 parse_where_block ();
6052 case ST_FORALL_BLOCK
:
6053 parse_forall_block ();
6056 case ST_OMP_ALLOCATE_EXEC
:
6057 case ST_OMP_ALLOCATORS
:
6058 st
= parse_openmp_allocate_block (st
);
6062 case ST_OMP_PARALLEL
:
6063 case ST_OMP_PARALLEL_MASKED
:
6064 case ST_OMP_PARALLEL_MASTER
:
6065 case ST_OMP_PARALLEL_SECTIONS
:
6066 st
= parse_omp_structured_block (st
, false);
6069 case ST_OMP_PARALLEL_WORKSHARE
:
6070 case ST_OMP_CRITICAL
:
6071 st
= parse_omp_structured_block (st
, true);
6074 case ST_OMP_PARALLEL_DO
:
6075 case ST_OMP_PARALLEL_DO_SIMD
:
6076 st
= parse_omp_do (st
);
6080 st
= parse_omp_oacc_atomic (true);
6091 st
= next_statement ();
6095 st
= parse_executable (st
);
6098 else if (st
== ST_OMP_SECTION
6099 && (omp_st
== ST_OMP_SECTIONS
6100 || omp_st
== ST_OMP_PARALLEL_SECTIONS
))
6102 np
= new_level (np
);
6105 st
= next_statement ();
6107 else if (block_construct
&& st
== ST_END_BLOCK
)
6109 accept_statement (st
);
6110 gfc_current_ns
->code
= gfc_state_stack
->head
;
6111 gfc_current_ns
= my_parent
;
6112 pop_state (); /* Inner BLOCK */
6113 pop_state (); /* Outer COMP_OMP_STRICTLY_STRUCTURED_BLOCK */
6115 st
= next_statement ();
6116 if (st
== omp_end_st
)
6118 accept_statement (st
);
6119 st
= next_statement ();
6123 else if (st
!= omp_end_st
|| block_construct
)
6125 unexpected_statement (st
);
6126 st
= next_statement ();
6129 while (st
!= omp_end_st
);
6133 case EXEC_OMP_END_NOWAIT
:
6134 if (cp
->ext
.omp_clauses
->nowait
&& new_st
.ext
.omp_bool
)
6135 gfc_error_now ("Duplicated NOWAIT clause on %s and %s at %C",
6136 gfc_ascii_statement (omp_st
),
6137 gfc_ascii_statement (omp_end_st
));
6138 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_bool
;
6140 case EXEC_OMP_END_CRITICAL
:
6141 if (((cp
->ext
.omp_clauses
->critical_name
== NULL
)
6142 ^ (new_st
.ext
.omp_name
== NULL
))
6143 || (new_st
.ext
.omp_name
!= NULL
6144 && strcmp (cp
->ext
.omp_clauses
->critical_name
,
6145 new_st
.ext
.omp_name
) != 0))
6146 gfc_error ("Name after !$omp critical and !$omp end critical does "
6148 free (CONST_CAST (char *, new_st
.ext
.omp_name
));
6149 new_st
.ext
.omp_name
= NULL
;
6151 case EXEC_OMP_END_SINGLE
:
6152 if (cp
->ext
.omp_clauses
->nowait
&& new_st
.ext
.omp_clauses
->nowait
)
6153 gfc_error_now ("Duplicated NOWAIT clause on %s and %s at %C",
6154 gfc_ascii_statement (omp_st
),
6155 gfc_ascii_statement (omp_end_st
));
6156 cp
->ext
.omp_clauses
->nowait
|= new_st
.ext
.omp_clauses
->nowait
;
6157 if (cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
])
6159 gfc_omp_namelist
*nl
;
6160 for (nl
= cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
6161 nl
->next
; nl
= nl
->next
)
6163 nl
->next
= new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
6166 cp
->ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
]
6167 = new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
];
6168 new_st
.ext
.omp_clauses
->lists
[OMP_LIST_COPYPRIVATE
] = NULL
;
6169 gfc_free_omp_clauses (new_st
.ext
.omp_clauses
);
6177 gfc_clear_new_st ();
6178 gfc_commit_symbols ();
6179 gfc_warning_check ();
6181 st
= next_statement ();
6186 /* Accept a series of executable statements. We return the first
6187 statement that doesn't fit to the caller. Any block statements are
6188 passed on to the correct handler, which usually passes the buck
6191 static gfc_statement
6192 parse_executable (gfc_statement st
)
6195 in_exec_part
= true;
6198 st
= next_statement ();
6202 close_flag
= check_do_closure ();
6207 case ST_END_PROGRAM
:
6210 case ST_END_FUNCTION
:
6215 case ST_END_SUBROUTINE
:
6220 case ST_SELECT_CASE
:
6221 gfc_error ("%s statement at %C cannot terminate a non-block "
6222 "DO loop", gfc_ascii_statement (st
));
6235 gfc_notify_std (GFC_STD_F95_OBS
, "DATA statement at %C after the "
6236 "first executable statement");
6242 accept_statement (st
);
6243 if (close_flag
== 1)
6244 return ST_IMPLIED_ENDDO
;
6248 parse_block_construct ();
6259 case ST_SELECT_CASE
:
6260 parse_select_block ();
6263 case ST_SELECT_TYPE
:
6264 parse_select_type_block ();
6267 case ST_SELECT_RANK
:
6268 parse_select_rank_block ();
6273 if (check_do_closure () == 1)
6274 return ST_IMPLIED_ENDDO
;
6278 parse_critical_block ();
6281 case ST_WHERE_BLOCK
:
6282 parse_where_block ();
6285 case ST_FORALL_BLOCK
:
6286 parse_forall_block ();
6289 case ST_OACC_PARALLEL_LOOP
:
6290 case ST_OACC_KERNELS_LOOP
:
6291 case ST_OACC_SERIAL_LOOP
:
6293 st
= parse_oacc_loop (st
);
6294 if (st
== ST_IMPLIED_ENDDO
)
6298 case ST_OACC_PARALLEL
:
6299 case ST_OACC_KERNELS
:
6300 case ST_OACC_SERIAL
:
6302 case ST_OACC_HOST_DATA
:
6303 parse_oacc_structured_block (st
);
6306 case ST_OMP_ALLOCATE_EXEC
:
6307 case ST_OMP_ALLOCATORS
:
6308 st
= parse_openmp_allocate_block (st
);
6312 case ST_OMP_PARALLEL
:
6313 case ST_OMP_PARALLEL_MASKED
:
6314 case ST_OMP_PARALLEL_MASTER
:
6315 case ST_OMP_PARALLEL_SECTIONS
:
6316 case ST_OMP_ORDERED
:
6317 case ST_OMP_CRITICAL
:
6321 case ST_OMP_SECTIONS
:
6324 case ST_OMP_TARGET_DATA
:
6325 case ST_OMP_TARGET_PARALLEL
:
6326 case ST_OMP_TARGET_TEAMS
:
6329 case ST_OMP_TASKGROUP
:
6330 st
= parse_omp_structured_block (st
, false);
6333 case ST_OMP_WORKSHARE
:
6334 case ST_OMP_PARALLEL_WORKSHARE
:
6335 st
= parse_omp_structured_block (st
, true);
6338 case ST_OMP_DISTRIBUTE
:
6339 case ST_OMP_DISTRIBUTE_PARALLEL_DO
:
6340 case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD
:
6341 case ST_OMP_DISTRIBUTE_SIMD
:
6343 case ST_OMP_DO_SIMD
:
6345 case ST_OMP_PARALLEL_DO
:
6346 case ST_OMP_PARALLEL_DO_SIMD
:
6347 case ST_OMP_PARALLEL_LOOP
:
6348 case ST_OMP_PARALLEL_MASKED_TASKLOOP
:
6349 case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD
:
6350 case ST_OMP_PARALLEL_MASTER_TASKLOOP
:
6351 case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD
:
6352 case ST_OMP_MASKED_TASKLOOP
:
6353 case ST_OMP_MASKED_TASKLOOP_SIMD
:
6354 case ST_OMP_MASTER_TASKLOOP
:
6355 case ST_OMP_MASTER_TASKLOOP_SIMD
:
6357 case ST_OMP_TARGET_PARALLEL_DO
:
6358 case ST_OMP_TARGET_PARALLEL_DO_SIMD
:
6359 case ST_OMP_TARGET_PARALLEL_LOOP
:
6360 case ST_OMP_TARGET_SIMD
:
6361 case ST_OMP_TARGET_TEAMS_DISTRIBUTE
:
6362 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO
:
6363 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
6364 case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD
:
6365 case ST_OMP_TARGET_TEAMS_LOOP
:
6366 case ST_OMP_TASKLOOP
:
6367 case ST_OMP_TASKLOOP_SIMD
:
6368 case ST_OMP_TEAMS_DISTRIBUTE
:
6369 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO
:
6370 case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD
:
6371 case ST_OMP_TEAMS_DISTRIBUTE_SIMD
:
6372 case ST_OMP_TEAMS_LOOP
:
6373 st
= parse_omp_do (st
);
6374 if (st
== ST_IMPLIED_ENDDO
)
6378 case ST_OACC_ATOMIC
:
6379 st
= parse_omp_oacc_atomic (false);
6383 st
= parse_omp_oacc_atomic (true);
6390 if (directive_unroll
!= -1)
6391 gfc_error ("%<GCC unroll%> directive not at the start of a loop at %C");
6393 if (directive_ivdep
)
6394 gfc_error ("%<GCC ivdep%> directive not at the start of a loop at %C");
6396 if (directive_vector
)
6397 gfc_error ("%<GCC vector%> directive not at the start of a loop at %C");
6399 if (directive_novector
)
6400 gfc_error ("%<GCC novector%> "
6401 "directive not at the start of a loop at %C");
6403 st
= next_statement ();
6408 /* Fix the symbols for sibling functions. These are incorrectly added to
6409 the child namespace as the parser didn't know about this procedure. */
6412 gfc_fixup_sibling_symbols (gfc_symbol
*sym
, gfc_namespace
*siblings
)
6416 gfc_symbol
*old_sym
;
6418 for (ns
= siblings
; ns
; ns
= ns
->sibling
)
6420 st
= gfc_find_symtree (ns
->sym_root
, sym
->name
);
6422 if (!st
|| (st
->n
.sym
->attr
.dummy
&& ns
== st
->n
.sym
->ns
))
6423 goto fixup_contained
;
6425 if ((st
->n
.sym
->attr
.flavor
== FL_DERIVED
6426 && sym
->attr
.generic
&& sym
->attr
.function
)
6427 ||(sym
->attr
.flavor
== FL_DERIVED
6428 && st
->n
.sym
->attr
.generic
&& st
->n
.sym
->attr
.function
))
6429 goto fixup_contained
;
6431 old_sym
= st
->n
.sym
;
6432 if (old_sym
->ns
== ns
6433 && !old_sym
->attr
.contained
6435 /* By 14.6.1.3, host association should be excluded
6436 for the following. */
6437 && !(old_sym
->attr
.external
6438 || (old_sym
->ts
.type
!= BT_UNKNOWN
6439 && !old_sym
->attr
.implicit_type
)
6440 || old_sym
->attr
.flavor
== FL_PARAMETER
6441 || old_sym
->attr
.use_assoc
6442 || old_sym
->attr
.in_common
6443 || old_sym
->attr
.in_equivalence
6444 || old_sym
->attr
.data
6445 || old_sym
->attr
.dummy
6446 || old_sym
->attr
.result
6447 || old_sym
->attr
.dimension
6448 || old_sym
->attr
.allocatable
6449 || old_sym
->attr
.intrinsic
6450 || old_sym
->attr
.generic
6451 || old_sym
->attr
.flavor
== FL_NAMELIST
6452 || old_sym
->attr
.flavor
== FL_LABEL
6453 || old_sym
->attr
.proc
== PROC_ST_FUNCTION
))
6455 /* Replace it with the symbol from the parent namespace. */
6459 gfc_release_symbol (old_sym
);
6463 /* Do the same for any contained procedures. */
6464 gfc_fixup_sibling_symbols (sym
, ns
->contained
);
6469 parse_contained (int module
)
6471 gfc_namespace
*ns
, *parent_ns
, *tmp
;
6472 gfc_state_data s1
, s2
;
6477 int contains_statements
= 0;
6480 push_state (&s1
, COMP_CONTAINS
, NULL
);
6481 parent_ns
= gfc_current_ns
;
6485 gfc_current_ns
= gfc_get_namespace (parent_ns
, 1);
6487 gfc_current_ns
->sibling
= parent_ns
->contained
;
6488 parent_ns
->contained
= gfc_current_ns
;
6491 /* Process the next available statement. We come here if we got an error
6492 and rejected the last statement. */
6493 old_loc
= gfc_current_locus
;
6494 st
= next_statement ();
6503 contains_statements
= 1;
6504 accept_statement (st
);
6507 (st
== ST_FUNCTION
) ? COMP_FUNCTION
: COMP_SUBROUTINE
,
6510 /* For internal procedures, create/update the symbol in the
6511 parent namespace. */
6515 if (gfc_get_symbol (gfc_new_block
->name
, parent_ns
, &sym
))
6516 gfc_error ("Contained procedure %qs at %C is already "
6517 "ambiguous", gfc_new_block
->name
);
6520 if (gfc_add_procedure (&sym
->attr
, PROC_INTERNAL
,
6522 &gfc_new_block
->declared_at
))
6524 if (st
== ST_FUNCTION
)
6525 gfc_add_function (&sym
->attr
, sym
->name
,
6526 &gfc_new_block
->declared_at
);
6528 gfc_add_subroutine (&sym
->attr
, sym
->name
,
6529 &gfc_new_block
->declared_at
);
6533 gfc_commit_symbols ();
6536 sym
= gfc_new_block
;
6538 /* Mark this as a contained function, so it isn't replaced
6539 by other module functions. */
6540 sym
->attr
.contained
= 1;
6542 /* Set implicit_pure so that it can be reset if any of the
6543 tests for purity fail. This is used for some optimisation
6544 during translation. */
6545 if (!sym
->attr
.pure
)
6546 sym
->attr
.implicit_pure
= 1;
6548 parse_progunit (ST_NONE
);
6550 /* Fix up any sibling functions that refer to this one. */
6551 gfc_fixup_sibling_symbols (sym
, gfc_current_ns
);
6552 /* Or refer to any of its alternate entry points. */
6553 for (el
= gfc_current_ns
->entries
; el
; el
= el
->next
)
6554 gfc_fixup_sibling_symbols (el
->sym
, gfc_current_ns
);
6556 gfc_current_ns
->code
= s2
.head
;
6557 gfc_current_ns
= parent_ns
;
6562 /* These statements are associated with the end of the host unit. */
6563 case ST_END_FUNCTION
:
6565 case ST_END_SUBMODULE
:
6566 case ST_END_PROGRAM
:
6567 case ST_END_SUBROUTINE
:
6568 accept_statement (st
);
6569 gfc_current_ns
->code
= s1
.head
;
6573 gfc_error ("Unexpected %s statement in CONTAINS section at %C",
6574 gfc_ascii_statement (st
));
6575 reject_statement ();
6581 while (st
!= ST_END_FUNCTION
&& st
!= ST_END_SUBROUTINE
6582 && st
!= ST_END_MODULE
&& st
!= ST_END_SUBMODULE
6583 && st
!= ST_END_PROGRAM
);
6585 /* The first namespace in the list is guaranteed to not have
6586 anything (worthwhile) in it. */
6587 tmp
= gfc_current_ns
;
6588 gfc_current_ns
= parent_ns
;
6589 if (seen_error
&& tmp
->refs
> 1)
6590 gfc_free_namespace (tmp
);
6592 ns
= gfc_current_ns
->contained
;
6593 gfc_current_ns
->contained
= ns
->sibling
;
6594 gfc_free_namespace (ns
);
6597 if (!contains_statements
)
6598 gfc_notify_std (GFC_STD_F2008
, "CONTAINS statement without "
6599 "FUNCTION or SUBROUTINE statement at %L", &old_loc
);
6603 /* The result variable in a MODULE PROCEDURE needs to be created and
6604 its characteristics copied from the interface since it is neither
6605 declared in the procedure declaration nor in the specification
6609 get_modproc_result (void)
6612 if (gfc_state_stack
->previous
6613 && gfc_state_stack
->previous
->state
== COMP_CONTAINS
6614 && gfc_state_stack
->previous
->previous
->state
== COMP_SUBMODULE
)
6616 proc
= gfc_current_ns
->proc_name
? gfc_current_ns
->proc_name
: NULL
;
6618 && proc
->attr
.function
6620 && proc
->tlink
->result
6621 && proc
->tlink
->result
!= proc
->tlink
)
6623 gfc_copy_dummy_sym (&proc
->result
, proc
->tlink
->result
, 1);
6624 gfc_set_sym_referenced (proc
->result
);
6625 proc
->result
->attr
.if_source
= IFSRC_DECL
;
6626 gfc_commit_symbol (proc
->result
);
6632 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct. */
6635 parse_progunit (gfc_statement st
)
6640 gfc_adjust_builtins ();
6643 && gfc_new_block
->abr_modproc_decl
6644 && gfc_new_block
->attr
.function
)
6645 get_modproc_result ();
6647 st
= parse_spec (st
);
6654 /* This is not allowed within BLOCK! */
6655 if (gfc_current_state () != COMP_BLOCK
)
6660 accept_statement (st
);
6667 if (gfc_current_state () == COMP_FUNCTION
)
6668 gfc_check_function_type (gfc_current_ns
);
6673 st
= parse_executable (st
);
6681 /* This is not allowed within BLOCK! */
6682 if (gfc_current_state () != COMP_BLOCK
)
6687 accept_statement (st
);
6694 unexpected_statement (st
);
6695 reject_statement ();
6696 st
= next_statement ();
6702 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
6703 if (p
->state
== COMP_CONTAINS
)
6706 if (gfc_find_state (COMP_MODULE
) == true
6707 || gfc_find_state (COMP_SUBMODULE
) == true)
6712 gfc_error ("CONTAINS statement at %C is already in a contained "
6714 reject_statement ();
6715 st
= next_statement ();
6719 parse_contained (0);
6722 gfc_current_ns
->code
= gfc_state_stack
->head
;
6726 /* Come here to complain about a global symbol already in use as
6730 gfc_global_used (gfc_gsymbol
*sym
, locus
*where
)
6735 where
= &gfc_current_locus
;
6745 case GSYM_SUBROUTINE
:
6746 name
= "SUBROUTINE";
6751 case GSYM_BLOCK_DATA
:
6752 name
= "BLOCK DATA";
6763 if (sym
->binding_label
)
6764 gfc_error ("Global binding name %qs at %L is already being used "
6765 "as a %s at %L", sym
->binding_label
, where
, name
,
6768 gfc_error ("Global name %qs at %L is already being used as "
6769 "a %s at %L", sym
->name
, where
, name
, &sym
->where
);
6773 if (sym
->binding_label
)
6774 gfc_error ("Global binding name %qs at %L is already being used "
6775 "at %L", sym
->binding_label
, where
, &sym
->where
);
6777 gfc_error ("Global name %qs at %L is already being used at %L",
6778 sym
->name
, where
, &sym
->where
);
6783 /* Parse a block data program unit. */
6786 parse_block_data (void)
6789 static locus blank_locus
;
6790 static int blank_block
=0;
6793 gfc_current_ns
->proc_name
= gfc_new_block
;
6794 gfc_current_ns
->is_block_data
= 1;
6796 if (gfc_new_block
== NULL
)
6799 gfc_error ("Blank BLOCK DATA at %C conflicts with "
6800 "prior BLOCK DATA at %L", &blank_locus
);
6804 blank_locus
= gfc_current_locus
;
6809 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6811 || (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_BLOCK_DATA
))
6812 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6815 s
->type
= GSYM_BLOCK_DATA
;
6816 s
->where
= gfc_new_block
->declared_at
;
6821 st
= parse_spec (ST_NONE
);
6823 while (st
!= ST_END_BLOCK_DATA
)
6825 gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
6826 gfc_ascii_statement (st
));
6827 reject_statement ();
6828 st
= next_statement ();
6833 /* Following the association of the ancestor (sub)module symbols, they
6834 must be set host rather than use associated and all must be public.
6835 They are flagged up by 'used_in_submodule' so that they can be set
6836 DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl). Otherwise the
6837 linker chokes on multiple symbol definitions. */
6840 set_syms_host_assoc (gfc_symbol
*sym
)
6843 const char dot
[2] = ".";
6844 /* Symbols take the form module.submodule_ or module.name_. */
6845 char parent1
[2 * GFC_MAX_SYMBOL_LEN
+ 2];
6846 char parent2
[2 * GFC_MAX_SYMBOL_LEN
+ 2];
6851 if (sym
->attr
.module_procedure
)
6852 sym
->attr
.external
= 0;
6854 sym
->attr
.use_assoc
= 0;
6855 sym
->attr
.host_assoc
= 1;
6856 sym
->attr
.used_in_submodule
=1;
6858 if (sym
->attr
.flavor
== FL_DERIVED
)
6860 /* Derived types with PRIVATE components that are declared in
6861 modules other than the parent module must not be changed to be
6862 PUBLIC. The 'use-assoc' attribute must be reset so that the
6863 test in symbol.cc(gfc_find_component) works correctly. This is
6864 not necessary for PRIVATE symbols since they are not read from
6866 memset(parent1
, '\0', sizeof(parent1
));
6867 memset(parent2
, '\0', sizeof(parent2
));
6868 strcpy (parent1
, gfc_new_block
->name
);
6869 strcpy (parent2
, sym
->module
);
6870 if (strcmp (strtok (parent1
, dot
), strtok (parent2
, dot
)) == 0)
6872 for (c
= sym
->components
; c
; c
= c
->next
)
6873 c
->attr
.access
= ACCESS_PUBLIC
;
6877 sym
->attr
.use_assoc
= 1;
6878 sym
->attr
.host_assoc
= 0;
6883 /* Parse a module subprogram. */
6891 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6892 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_MODULE
))
6893 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6896 s
->type
= GSYM_MODULE
;
6897 s
->where
= gfc_new_block
->declared_at
;
6901 /* Something is nulling the module_list after this point. This is good
6902 since it allows us to 'USE' the parent modules that the submodule
6903 inherits and to set (most) of the symbols as host associated. */
6904 if (gfc_current_state () == COMP_SUBMODULE
)
6907 gfc_traverse_ns (gfc_current_ns
, set_syms_host_assoc
);
6910 st
= parse_spec (ST_NONE
);
6919 parse_contained (1);
6923 case ST_END_SUBMODULE
:
6924 accept_statement (st
);
6928 gfc_error ("Unexpected %s statement in MODULE at %C",
6929 gfc_ascii_statement (st
));
6930 reject_statement ();
6931 st
= next_statement ();
6934 s
->ns
= gfc_current_ns
;
6938 /* Add a procedure name to the global symbol table. */
6941 add_global_procedure (bool sub
)
6945 /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6946 name is a global identifier. */
6947 if (!gfc_new_block
->binding_label
|| gfc_notification_std (GFC_STD_F2008
))
6949 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
6952 || (s
->type
!= GSYM_UNKNOWN
6953 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
6955 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6956 /* Silence follow-up errors. */
6957 gfc_new_block
->binding_label
= NULL
;
6961 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6962 s
->sym_name
= gfc_new_block
->name
;
6963 s
->where
= gfc_new_block
->declared_at
;
6965 s
->ns
= gfc_current_ns
;
6969 /* Don't add the symbol multiple times. */
6970 if (gfc_new_block
->binding_label
6971 && (!gfc_notification_std (GFC_STD_F2008
)
6972 || strcmp (gfc_new_block
->name
, gfc_new_block
->binding_label
) != 0))
6974 s
= gfc_get_gsymbol (gfc_new_block
->binding_label
, true);
6977 || (s
->type
!= GSYM_UNKNOWN
6978 && s
->type
!= (sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
)))
6980 gfc_global_used (s
, &gfc_new_block
->declared_at
);
6981 /* Silence follow-up errors. */
6982 gfc_new_block
->binding_label
= NULL
;
6986 s
->type
= sub
? GSYM_SUBROUTINE
: GSYM_FUNCTION
;
6987 s
->sym_name
= gfc_new_block
->name
;
6988 s
->binding_label
= gfc_new_block
->binding_label
;
6989 s
->where
= gfc_new_block
->declared_at
;
6991 s
->ns
= gfc_current_ns
;
6997 /* Add a program to the global symbol table. */
7000 add_global_program (void)
7004 if (gfc_new_block
== NULL
)
7006 s
= gfc_get_gsymbol (gfc_new_block
->name
, false);
7008 if (s
->defined
|| (s
->type
!= GSYM_UNKNOWN
&& s
->type
!= GSYM_PROGRAM
))
7009 gfc_global_used (s
, &gfc_new_block
->declared_at
);
7012 s
->type
= GSYM_PROGRAM
;
7013 s
->where
= gfc_new_block
->declared_at
;
7015 s
->ns
= gfc_current_ns
;
7020 /* Resolve all the program units. */
7022 resolve_all_program_units (gfc_namespace
*gfc_global_ns_list
)
7024 gfc_derived_types
= NULL
;
7025 gfc_current_ns
= gfc_global_ns_list
;
7026 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
7028 if (gfc_current_ns
->proc_name
7029 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
7030 continue; /* Already resolved. */
7032 if (gfc_current_ns
->proc_name
)
7033 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
7034 gfc_resolve (gfc_current_ns
);
7035 gfc_current_ns
->derived_types
= gfc_derived_types
;
7036 gfc_derived_types
= NULL
;
7042 clean_up_modules (gfc_gsymbol
*&gsym
)
7047 clean_up_modules (gsym
->left
);
7048 clean_up_modules (gsym
->right
);
7050 if (gsym
->type
!= GSYM_MODULE
)
7055 gfc_current_ns
= gsym
->ns
;
7056 gfc_derived_types
= gfc_current_ns
->derived_types
;
7065 /* Translate all the program units. This could be in a different order
7066 to resolution if there are forward references in the file. */
7068 translate_all_program_units (gfc_namespace
*gfc_global_ns_list
)
7072 gfc_current_ns
= gfc_global_ns_list
;
7073 gfc_get_errors (NULL
, &errors
);
7075 /* We first translate all modules to make sure that later parts
7076 of the program can use the decl. Then we translate the nonmodules. */
7078 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
7080 if (!gfc_current_ns
->proc_name
7081 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7084 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
7085 gfc_derived_types
= gfc_current_ns
->derived_types
;
7086 gfc_generate_module_code (gfc_current_ns
);
7087 gfc_current_ns
->translated
= 1;
7090 gfc_current_ns
= gfc_global_ns_list
;
7091 for (; !errors
&& gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
7093 if (gfc_current_ns
->proc_name
7094 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
7097 gfc_current_locus
= gfc_current_ns
->proc_name
->declared_at
;
7098 gfc_derived_types
= gfc_current_ns
->derived_types
;
7099 gfc_generate_code (gfc_current_ns
);
7100 gfc_current_ns
->translated
= 1;
7103 /* Clean up all the namespaces after translation. */
7104 gfc_current_ns
= gfc_global_ns_list
;
7105 for (;gfc_current_ns
;)
7109 if (gfc_current_ns
->proc_name
7110 && gfc_current_ns
->proc_name
->attr
.flavor
== FL_MODULE
)
7112 gfc_current_ns
= gfc_current_ns
->sibling
;
7116 ns
= gfc_current_ns
->sibling
;
7117 gfc_derived_types
= gfc_current_ns
->derived_types
;
7119 gfc_current_ns
= ns
;
7122 clean_up_modules (gfc_gsym_root
);
7126 /* Top level parser. */
7129 gfc_parse_file (void)
7131 int seen_program
, errors_before
, errors
;
7132 gfc_state_data top
, s
;
7135 gfc_namespace
*next
;
7137 gfc_start_source_files ();
7139 top
.state
= COMP_NONE
;
7141 top
.previous
= NULL
;
7142 top
.head
= top
.tail
= NULL
;
7143 top
.do_variable
= NULL
;
7145 gfc_state_stack
= &top
;
7147 gfc_clear_new_st ();
7149 gfc_statement_label
= NULL
;
7151 if (setjmp (eof_buf
))
7152 return false; /* Come here on unexpected EOF */
7154 /* Prepare the global namespace that will contain the
7156 gfc_global_ns_list
= next
= NULL
;
7161 /* Exit early for empty files. */
7165 in_specification_block
= true;
7168 st
= next_statement ();
7177 goto duplicate_main
;
7179 prog_locus
= gfc_current_locus
;
7181 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
7182 main_program_symbol (gfc_current_ns
, gfc_new_block
->name
);
7183 accept_statement (st
);
7184 add_global_program ();
7185 parse_progunit (ST_NONE
);
7189 add_global_procedure (true);
7190 push_state (&s
, COMP_SUBROUTINE
, gfc_new_block
);
7191 accept_statement (st
);
7192 parse_progunit (ST_NONE
);
7196 add_global_procedure (false);
7197 push_state (&s
, COMP_FUNCTION
, gfc_new_block
);
7198 accept_statement (st
);
7199 parse_progunit (ST_NONE
);
7203 push_state (&s
, COMP_BLOCK_DATA
, gfc_new_block
);
7204 accept_statement (st
);
7205 parse_block_data ();
7209 push_state (&s
, COMP_MODULE
, gfc_new_block
);
7210 accept_statement (st
);
7212 gfc_get_errors (NULL
, &errors_before
);
7217 push_state (&s
, COMP_SUBMODULE
, gfc_new_block
);
7218 accept_statement (st
);
7220 gfc_get_errors (NULL
, &errors_before
);
7224 /* Anything else starts a nameless main program block. */
7227 goto duplicate_main
;
7229 prog_locus
= gfc_current_locus
;
7231 push_state (&s
, COMP_PROGRAM
, gfc_new_block
);
7232 main_program_symbol (gfc_current_ns
, "MAIN__");
7233 parse_progunit (st
);
7237 /* Handle the non-program units. */
7238 gfc_current_ns
->code
= s
.head
;
7240 gfc_resolve (gfc_current_ns
);
7242 /* Fix the implicit_pure attribute for those procedures who should
7244 while (gfc_fix_implicit_pure (gfc_current_ns
))
7247 /* Dump the parse tree if requested. */
7248 if (flag_dump_fortran_original
)
7249 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
7251 gfc_get_errors (NULL
, &errors
);
7252 if (s
.state
== COMP_MODULE
|| s
.state
== COMP_SUBMODULE
)
7254 gfc_dump_module (s
.sym
->name
, errors_before
== errors
);
7255 gfc_current_ns
->derived_types
= gfc_derived_types
;
7256 gfc_derived_types
= NULL
;
7262 gfc_generate_code (gfc_current_ns
);
7270 /* The main program and non-contained procedures are put
7271 in the global namespace list, so that they can be processed
7272 later and all their interfaces resolved. */
7273 gfc_current_ns
->code
= s
.head
;
7276 for (; next
->sibling
; next
= next
->sibling
)
7278 next
->sibling
= gfc_current_ns
;
7281 gfc_global_ns_list
= gfc_current_ns
;
7283 next
= gfc_current_ns
;
7289 /* Do the resolution. */
7290 resolve_all_program_units (gfc_global_ns_list
);
7292 /* Go through all top-level namespaces and unset the implicit_pure
7293 attribute for any procedures that call something not pure or
7294 implicit_pure. Because the a procedure marked as not implicit_pure
7295 in one sweep may be called by another routine, we repeat this
7296 process until there are no more changes. */
7301 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
7302 gfc_current_ns
= gfc_current_ns
->sibling
)
7304 if (gfc_fix_implicit_pure (gfc_current_ns
))
7310 /* Fixup for external procedures and resolve 'omp requires'. */
7312 bool omp_target_seen
;
7314 omp_target_seen
= false;
7315 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
7316 gfc_current_ns
= gfc_current_ns
->sibling
)
7318 omp_requires
|= gfc_current_ns
->omp_requires
;
7319 omp_target_seen
|= gfc_current_ns
->omp_target_seen
;
7320 gfc_check_externals (gfc_current_ns
);
7322 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
7323 gfc_current_ns
= gfc_current_ns
->sibling
)
7324 gfc_check_omp_requires (gfc_current_ns
, omp_requires
);
7326 /* Populate omp_requires_mask (needed for resolving OpenMP
7327 metadirectives and declare variant). */
7328 switch (omp_requires
& OMP_REQ_ATOMIC_MEM_ORDER_MASK
)
7330 case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST
:
7332 = (enum omp_requires
) (omp_requires_mask
| OMP_MEMORY_ORDER_SEQ_CST
);
7334 case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL
:
7336 = (enum omp_requires
) (omp_requires_mask
| OMP_MEMORY_ORDER_ACQ_REL
);
7338 case OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE
:
7340 = (enum omp_requires
) (omp_requires_mask
| OMP_MEMORY_ORDER_ACQUIRE
);
7342 case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED
:
7344 = (enum omp_requires
) (omp_requires_mask
| OMP_MEMORY_ORDER_RELAXED
);
7346 case OMP_REQ_ATOMIC_MEM_ORDER_RELEASE
:
7348 = (enum omp_requires
) (omp_requires_mask
| OMP_MEMORY_ORDER_RELEASE
);
7352 if (omp_target_seen
)
7353 omp_requires_mask
= (enum omp_requires
) (omp_requires_mask
7354 | OMP_REQUIRES_TARGET_USED
);
7355 if (omp_requires
& OMP_REQ_REVERSE_OFFLOAD
)
7356 omp_requires_mask
= (enum omp_requires
) (omp_requires_mask
7357 | OMP_REQUIRES_REVERSE_OFFLOAD
);
7358 if (omp_requires
& OMP_REQ_UNIFIED_ADDRESS
)
7359 omp_requires_mask
= (enum omp_requires
) (omp_requires_mask
7360 | OMP_REQUIRES_UNIFIED_ADDRESS
);
7361 if (omp_requires
& OMP_REQ_UNIFIED_SHARED_MEMORY
)
7363 = (enum omp_requires
) (omp_requires_mask
7364 | OMP_REQUIRES_UNIFIED_SHARED_MEMORY
);
7365 if (omp_requires
& OMP_REQ_DYNAMIC_ALLOCATORS
)
7366 omp_requires_mask
= (enum omp_requires
) (omp_requires_mask
7367 | OMP_REQUIRES_DYNAMIC_ALLOCATORS
);
7368 /* Do the parse tree dump. */
7369 gfc_current_ns
= flag_dump_fortran_original
? gfc_global_ns_list
: NULL
;
7371 for (; gfc_current_ns
; gfc_current_ns
= gfc_current_ns
->sibling
)
7372 if (!gfc_current_ns
->proc_name
7373 || gfc_current_ns
->proc_name
->attr
.flavor
!= FL_MODULE
)
7375 gfc_dump_parse_tree (gfc_current_ns
, stdout
);
7376 fputs ("------------------------------------------\n\n", stdout
);
7379 /* Dump C prototypes. */
7380 if (flag_c_prototypes
|| flag_c_prototypes_external
)
7383 "#include <stddef.h>\n"
7384 "#ifdef __cplusplus\n"
7385 "#include <complex>\n"
7386 "#define __GFORTRAN_FLOAT_COMPLEX std::complex<float>\n"
7387 "#define __GFORTRAN_DOUBLE_COMPLEX std::complex<double>\n"
7388 "#define __GFORTRAN_LONG_DOUBLE_COMPLEX std::complex<long double>\n"
7391 "#define __GFORTRAN_FLOAT_COMPLEX float _Complex\n"
7392 "#define __GFORTRAN_DOUBLE_COMPLEX double _Complex\n"
7393 "#define __GFORTRAN_LONG_DOUBLE_COMPLEX long double _Complex\n"
7397 /* First dump BIND(C) prototypes. */
7398 if (flag_c_prototypes
)
7400 for (gfc_current_ns
= gfc_global_ns_list
; gfc_current_ns
;
7401 gfc_current_ns
= gfc_current_ns
->sibling
)
7402 gfc_dump_c_prototypes (gfc_current_ns
, stdout
);
7405 /* Dump external prototypes. */
7406 if (flag_c_prototypes_external
)
7407 gfc_dump_external_c_prototypes (stdout
);
7409 if (flag_c_prototypes
|| flag_c_prototypes_external
)
7410 fprintf (stdout
, "\n#ifdef __cplusplus\n}\n#endif\n");
7412 /* Do the translation. */
7413 translate_all_program_units (gfc_global_ns_list
);
7415 /* Dump the global symbol ist. We only do this here because part
7416 of it is generated after mangling the identifiers in
7419 if (flag_dump_fortran_global
)
7420 gfc_dump_global_symbols (stdout
);
7422 gfc_end_source_files ();
7426 /* If we see a duplicate main program, shut down. If the second
7427 instance is an implied main program, i.e. data decls or executable
7428 statements, we're in for lots of errors. */
7429 gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus
);
7430 reject_statement ();
7435 /* Return true if this state data represents an OpenACC region. */
7437 is_oacc (gfc_state_data
*sd
)
7439 switch (sd
->construct
->op
)
7441 case EXEC_OACC_PARALLEL_LOOP
:
7442 case EXEC_OACC_PARALLEL
:
7443 case EXEC_OACC_KERNELS_LOOP
:
7444 case EXEC_OACC_KERNELS
:
7445 case EXEC_OACC_SERIAL_LOOP
:
7446 case EXEC_OACC_SERIAL
:
7447 case EXEC_OACC_DATA
:
7448 case EXEC_OACC_HOST_DATA
:
7449 case EXEC_OACC_LOOP
:
7450 case EXEC_OACC_UPDATE
:
7451 case EXEC_OACC_WAIT
:
7452 case EXEC_OACC_CACHE
:
7453 case EXEC_OACC_ENTER_DATA
:
7454 case EXEC_OACC_EXIT_DATA
:
7455 case EXEC_OACC_ATOMIC
:
7456 case EXEC_OACC_ROUTINE
: