https://gcc.gnu.org/bugzilla/show_bug.cgi?id=93635
--- Comment #2 from Steve Kargl <sgk at troutmask dot apl.washington.edu> ---
On Sun, Feb 09, 2020 at 06:39:31PM +0000, kargl at gcc dot gnu.org wrote:
>
> Fortuantely, I
> use neither namelist nor equivalence, so have no skin in the
> game. Someone else can complete the fix.
>
Here's a patch that fixes the issue and cures the ICE in the
old testcase. Whoever commit patch needs to convert the
example code here into a testcase.
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 280157)
+++ gcc/fortran/symbol.c (working copy)
@@ -394,18 +395,35 @@ gfc_check_function_type (gfc_namespace *ns)
/******************** Symbol attribute stuff *********************/
+/* Older standard produced conflicts for some attributes that are now
+ allowed in newer standards. Check for the conflict and issue an
+ error depending on the standard in play. */
+
+static bool
+conflict_std (int standard, const char *a1, const char *a2, const char *name,
+ locus *where)
+{
+ if (name == NULL)
+ {
+ return gfc_notify_std (standard, "%s attribute conflicts "
+ "with %s attribute at %L", a1, a2,
+ where);
+ }
+ else
+ {
+ return gfc_notify_std (standard, "%s attribute conflicts "
+ "with %s attribute in %qs at %L",
+ a1, a2, name, where);
+ }
+}
+
+
+
/* This is a generic conflict-checker. We do this to avoid having a
single conflict in two places. */
#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
#define conf2(a) if (attr->a) { a2 = a; goto conflict; }
-#define conf_std(a, b, std) if (attr->a && attr->b)\
- {\
- a1 = a;\
- a2 = b;\
- standard = std;\
- goto conflict_std;\
- }
bool
gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
@@ -438,7 +456,7 @@ gfc_check_conflict (symbol_attribute *attr, const char
"OACC DECLARE DEVICE_RESIDENT";
const char *a1, *a2;
- int standard;
+ bool standard;
if (attr->artificial)
return true;
@@ -450,16 +468,18 @@ gfc_check_conflict (symbol_attribute *attr, const char
{
a1 = pointer;
a2 = intent;
- standard = GFC_STD_F2003;
- goto conflict_std;
+ standard = conflict_std (GFC_STD_F2003, a1, a2, name, where);
+ if (!standard)
+ return standard;
}
if (attr->in_namelist && (attr->allocatable || attr->pointer))
{
a1 = in_namelist;
a2 = attr->allocatable ? allocatable : pointer;
- standard = GFC_STD_F2003;
- goto conflict_std;
+ standard = conflict_std (GFC_STD_F2003, a1, a2, name, where);
+ if (!standard)
+ return standard;
}
/* Check for attributes not allowed in a BLOCK DATA. */
@@ -566,9 +586,31 @@ gfc_check_conflict (symbol_attribute *attr, const char
return false;
conf (allocatable, pointer);
- conf_std (allocatable, dummy, GFC_STD_F2003);
- conf_std (allocatable, function, GFC_STD_F2003);
- conf_std (allocatable, result, GFC_STD_F2003);
+ if (attr->allocatable && attr->dummy)
+ {
+ a1 = allocatable;
+ a2 = dummy;
+ standard = conflict_std (GFC_STD_F2003, a1, a2, name, where);
+ if (!standard)
+ return standard;
+ }
+ if (attr->allocatable && attr->function)
+ {
+ a1 = allocatable;
+ a2 = function;
+ standard = conflict_std (GFC_STD_F2003, a1, a2, name, where);
+ if (!standard)
+ return standard;
+ }
+ if (attr->allocatable && attr->result)
+ {
+ a1 = allocatable;
+ a2 = result;
+ standard = conflict_std (GFC_STD_F2003, a1, a2, name, where);
+ if (!standard)
+ return standard;
+ }
+
conf (elemental, recursive);
conf (in_common, dummy);
@@ -908,25 +950,10 @@ conflict:
a1, a2, name, where);
return false;
-
-conflict_std:
- if (name == NULL)
- {
- return gfc_notify_std (standard, "%s attribute conflicts "
- "with %s attribute at %L", a1, a2,
- where);
- }
- else
- {
- return gfc_notify_std (standard, "%s attribute conflicts "
- "with %s attribute in %qs at %L",
- a1, a2, name, where);
- }
}
#undef conf
#undef conf2
-#undef conf_std
/* Mark a symbol as referenced. */
@@ -4039,6 +4066,31 @@ gfc_free_namespace (gfc_namespace *ns)
ns->refs--;
if (ns->refs > 0)
return;
+
+ /* If an error occurred while parsing a submodule, the namespace is freed.
+ However, gfortran reaches a ref count of -1. Note, gfc_state_stack does
+ not indicate that gfortran was parsing a submodule. */
+ if (ns->refs == -1)
+ {
+ gcc_assert (ns->sym_root == NULL);
+ gcc_assert (ns->uop_root == NULL);
+ gcc_assert (ns->common_root == NULL);
+ gcc_assert (ns->omp_udr_root == NULL);
+ gcc_assert (ns->tb_sym_root == NULL);
+ gcc_assert (ns->tb_uop_root == NULL);
+ gcc_assert (ns->finalizers == NULL);
+ gcc_assert (ns->omp_declare_simd == NULL);
+ gcc_assert (ns->cl_list == NULL);
+ gcc_assert (ns->st_labels == NULL);
+ gcc_assert (ns->entries == NULL);
+ gcc_assert (ns->equiv == NULL);
+ gcc_assert (ns->equiv_lists == NULL);
+ gcc_assert (ns->use_stmts == NULL);
+ gcc_assert (ns->data == NULL);
+ gcc_assert (ns->contained == NULL);
+ free (ns);
+ return;
+ }
gcc_assert (ns->refs == 0);
Index: gcc/testsuite/gfortran.dg/pr87907.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr87907.f90 (revision 280157)
+++ gcc/testsuite/gfortran.dg/pr87907.f90 (working copy)
@@ -12,12 +12,6 @@ end
submodule(m) m2
contains
- subroutine g(x) ! { dg-error "mismatch in argument" }
+ subroutine g(x) ! { dg-error " attribute conflicts with" }
end
-end
-
-program p
- use m ! { dg-error "has a type" }
- integer :: x = 3
- call g(x) ! { dg-error "which is not consistent with" }
end
