void gfc_free_st_label (gfc_st_label *);
void gfc_define_st_label (gfc_st_label *, gfc_sl_type, locus *);
bool gfc_reference_st_label (gfc_st_label *, gfc_sl_type);
+gfc_st_label *gfc_rebind_label (gfc_st_label *, int);
gfc_namespace *gfc_get_namespace (gfc_namespace *, int);
gfc_symtree *gfc_new_symtree (gfc_symtree **, const char *);
/* Each metadirective body in the translation unit is given a unique
number, used to ensure that labels in the body have unique names. */
int gfc_omp_metadirective_region_count;
+vec<int> gfc_omp_metadirective_region_stack;
/* TODO: Re-order functions to kill these forward decls. */
static void check_statement_label (gfc_statement);
gfc_in_omp_metadirective_body = true;
gfc_omp_metadirective_region_count++;
+ gfc_omp_metadirective_region_stack.safe_push (
+ gfc_omp_metadirective_region_count);
+
switch (variant->stmt)
{
case_omp_structured_block:
*variant->code = *gfc_state_stack->head;
pop_state ();
+ gfc_omp_metadirective_region_stack.pop ();
+ int outer_omp_metadirective_region
+ = gfc_omp_metadirective_region_stack.last ();
+
+ /* Rebind labels in the last statement -- which is the first statement
+ past the end of the metadirective body -- to the outer region. */
+ if (gfc_statement_label)
+ gfc_statement_label = gfc_rebind_label (gfc_statement_label,
+ outer_omp_metadirective_region);
+ if ((new_st.op == EXEC_READ || new_st.op == EXEC_WRITE)
+ && new_st.ext.dt->format_label
+ && new_st.ext.dt->format_label != &format_asterisk)
+ new_st.ext.dt->format_label
+ = gfc_rebind_label (new_st.ext.dt->format_label,
+ outer_omp_metadirective_region);
+ if (new_st.label1)
+ new_st.label1
+ = gfc_rebind_label (new_st.label1, outer_omp_metadirective_region);
+ if (new_st.here)
+ new_st.here
+ = gfc_rebind_label (new_st.here, outer_omp_metadirective_region);
+
gfc_commit_symbols ();
gfc_warning_check ();
if (variant->next)
gfc_statement_label = NULL;
gfc_omp_metadirective_region_count = 0;
+ gfc_omp_metadirective_region_stack.truncate (0);
+ gfc_omp_metadirective_region_stack.safe_push (0);
gfc_in_omp_metadirective_body = false;
gfc_matching_omp_context_selector = false;
#ifndef GFC_PARSE_H
#define GFC_PARSE_H
+#include "vec.h"
+
/* Enum for what the compiler is currently doing. */
enum gfc_compile_state
{
extern bool gfc_matching_omp_context_selector;
extern bool gfc_in_omp_metadirective_body;
extern int gfc_omp_metadirective_region_count;
+extern vec<int> gfc_omp_metadirective_region_stack;
match gfc_match_prefix (gfc_typespec *);
bool is_oacc (gfc_state_data *);
{
gfc_st_label *lp;
gfc_namespace *ns;
- int omp_region = (gfc_in_omp_metadirective_body
- ? gfc_omp_metadirective_region_count : 0);
+ int omp_region = gfc_omp_metadirective_region_stack.last ();
if (gfc_current_state () == COMP_DERIVED)
ns = gfc_current_block ()->f2k_derived;
}
/* First see if the label is already in this namespace. */
- lp = ns->st_labels;
- while (lp)
+ gcc_checking_assert (gfc_omp_metadirective_region_stack.length () > 0);
+ for (int omp_region_idx = gfc_omp_metadirective_region_stack.length () - 1;
+ omp_region_idx >= 0; omp_region_idx--)
{
- if (lp->omp_region == omp_region)
+ int omp_region2 = gfc_omp_metadirective_region_stack[omp_region_idx];
+ lp = ns->st_labels;
+ while (lp)
{
- if (lp->value == labelno)
- return lp;
- if (lp->value < labelno)
+ if (lp->omp_region == omp_region2)
+ {
+ if (lp->value == labelno)
+ return lp;
+ if (lp->value < labelno)
+ lp = lp->left;
+ else
+ lp = lp->right;
+ }
+ else if (lp->omp_region < omp_region2)
lp = lp->left;
else
lp = lp->right;
}
- else if (lp->omp_region < omp_region)
- lp = lp->left;
- else
- lp = lp->right;
}
lp = XCNEW (gfc_st_label);
return lp;
}
+/* Rebind a statement label to a new OpenMP region. If a label with the same
+ value already exists in the new region, update it and return it. Otherwise,
+ move the label to the new region. */
+
+gfc_st_label *
+gfc_rebind_label (gfc_st_label *label, int new_omp_region)
+{
+ gfc_st_label *lp = label->ns->st_labels;
+ int labelno = label->value;
+
+ while (lp)
+ {
+ if (lp->omp_region == new_omp_region)
+ {
+ if (lp->value == labelno)
+ {
+ if (lp == label)
+ return label;
+ if (lp->defined == ST_LABEL_UNKNOWN
+ && label->defined != ST_LABEL_UNKNOWN)
+ lp->defined = label->defined;
+ if (lp->referenced == ST_LABEL_UNKNOWN
+ && label->referenced != ST_LABEL_UNKNOWN)
+ lp->referenced = label->referenced;
+ if (lp->format == NULL && label->format != NULL)
+ lp->format = label->format;
+ gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels);
+ return lp;
+ }
+ if (lp->value < labelno)
+ lp = lp->left;
+ else
+ lp = lp->right;
+ }
+ else if (lp->omp_region < new_omp_region)
+ lp = lp->left;
+ else
+ lp = lp->right;
+ }
+
+ gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels);
+ label->left = nullptr;
+ label->right = nullptr;
+ label->omp_region = new_omp_region;
+ gfc_insert_bbt (&label->ns->st_labels, label, compare_st_labels);
+ return label;
+}
/* Called when a statement with a statement label is about to be
accepted. We add the label to the list of the current namespace,
labelno = lp->value;
- if (lp->defined != ST_LABEL_UNKNOWN)
+ if (lp->defined != ST_LABEL_UNKNOWN && !gfc_in_omp_metadirective_body)
gfc_error ("Duplicate statement label %d at %L and %L", labelno,
&lp->where, label_locus);
else
}
if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET
+ && !gfc_in_omp_metadirective_body
&& !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
"Shared DO termination label %d at %C", labelno))
return false;
--- /dev/null
+! { dg-do compile }
+! { dg-additional-options "-Wunused-label" }
+
+! Check that a format label referenced in the first statement past a
+! metadirective body is bound to the outer region.
+
+!$omp metadirective when(user={condition(.true.)}: target teams &
+!$omp& distribute parallel do)
+ DO JCHECK = 1, MNMIN
+ END DO
+ WRITE(6,366) PCHECK, UCHECK, VCHECK
+ 366 FORMAT(/, ' Vcheck = ',E12.4,/)
+ END PROGRAM
--- /dev/null
+! { dg-do compile }
+! { dg-additional-options "-Wunused-label" }
+
+! Check that a statement label that ends a loop in the first statement past a
+! metadirective body is bound to the outer region.
+
+implicit none
+integer :: i, j
+logical :: cond1, cond2
+integer :: A(0:10,0:5), B(0:10,0:5)
+
+cond1 = .true.
+cond2 = .true.
+
+!$omp metadirective when(user={condition(cond1)} : parallel do collapse(2))
+ do 50 j = 0, 5
+!$omp metadirective when(user={condition(.false.)} : simd)
+ do 51 i = 0, 10
+ A(i,j) = i*10 + j
+ 51 continue
+ 50 continue
+
+ do 55 i = 0, 5
+ 55 continue
+
+!$omp begin metadirective when(user={condition(cond2)} : parallel do collapse(2))
+ do 60 j = 0, 5
+!$omp metadirective when(user={condition(.false.)} : simd)
+ do 61 i = 0, 10
+ B(i,j) = i*10 + j
+ 61 continue
+ 60 continue
+!$omp end metadirective
+
+ do 70 j = 0, 5
+ 70 continue
+end
--- /dev/null
+! { dg-do compile }
+! { dg-additional-options "-Wunused-label" }
+
+! Check that a statement label defined in the first statement past a
+! metadirective body is bound to the outer region.
+
+
+integer :: cnt, x
+
+cnt = 0
+!$omp begin metadirective when(user={condition(cnt > 0)} : parallel)
+ x = 5
+!$omp end metadirective
+1234 format("Hello")
+write(*,1234)
+
+!$omp begin metadirective when(user={condition(x > 0)} : parallel)
+ x = 5
+!$omp end metadirective
+4567 print *, 'hello', cnt
+cnt = cnt + 1
+if (cnt < 2) goto 4567
+end
--- /dev/null
+! { dg-do compile }
+! { dg-additional-options "-Wunused-label" }
+
+! Check that a format label defined in the first statement after a nested
+! metadirective body can be referenced correctly.
+
+integer :: cnt, x
+cnt = 0
+!$omp begin metadirective when(user={condition(cnt > 0)} : parallel)
+ !$omp begin metadirective when(user={condition(cnt > 0)} : parallel)
+ x = 5
+ !$omp end metadirective
+ 1234 format("Hello")
+ write(*,1234)
+!$omp end metadirective
+end
--- /dev/null
+! { dg-do compile }
+! { dg-additional-options "-Wunused-label" }
+
+! Check that a format label defined outside a metadirective body can be
+! referenced correctly inside the metadirective body.
+
+implicit none
+integer :: cnt
+1345 format("The count is ", g0)
+
+cnt = 0
+write(*,1345) cnt
+
+!$omp begin metadirective when(user={condition(cnt > 0)} : parallel)
+ write(*,1345) cnt
+!$omp end metadirective
+end
--- /dev/null
+! { dg-do compile }
+
+! Check that redefining labels across metadirective regions triggers a
+! diagnostic.
+
+implicit none
+integer :: cnt
+1345 format("The count is ", g0)
+
+cnt = 0
+write(*,1345) cnt
+
+!$omp begin metadirective when(user={condition(cnt > 0)} : parallel)
+ 6789 format("The count is ", g0)
+ !$omp begin metadirective when(user={condition(cnt > 0)} : parallel)
+ 1345 print *, 'nested' ! { dg-error "Label 1345 at .1. already referenced as a format label" }
+ 6789 print *, 'world'
+ !$omp end metadirective
+ write(*,1345) cnt ! { dg-error "Label 1345 at .1. previously used as branch target" }
+ write(*,6789) cnt ! { dg-error "Label 6789 at .1. previously used as branch target" }
+!$omp end metadirective
+end
projects / thirdparty / gcc.git / commitdiff
