Using "associate (y => procedure_name)" and
"associate (y => derived_type_name)" failed with an ICE
when converting to a tree. This patch rejects those now.
(This is a GCC 10 regression; before there was no ICE but
the code was silently accepted.)
OK?
Tobias
-----------------
Mentor Graphics (Deutschland) GmbH, Arnulfstraße 201, 80634 München / Germany
Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Alexander
Walter
2020-03-27 Tobias Burnus <tob...@codesourcery.com>
PR fortran/93363
* resolve.c (resolve_assoc_var): Reject association to DT and
function name.
PR fortran/93363
* gfortran.dg/associate_51.f90: Fix test case.
* gfortran.dg/associate_53.f90: New.
gcc/fortran/resolve.c | 32 +++++++++++---
gcc/testsuite/gfortran.dg/associate_51.f90 | 2 +-
gcc/testsuite/gfortran.dg/associate_53.f90 | 71 ++++++++++++++++++++++++++++++
3 files changed, 97 insertions(+), 8 deletions(-)
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 2dcb261fc71..b6277d236da 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8868,27 +8868,45 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
/* For variable targets, we get some attributes from the target. */
if (target->expr_type == EXPR_VARIABLE)
{
- gfc_symbol* tsym;
+ gfc_symbol *tsym, *dsym;
gcc_assert (target->symtree);
tsym = target->symtree->n.sym;
- if (tsym->attr.subroutine
- || tsym->attr.external
- || (tsym->attr.function && tsym->result != tsym))
+ if (gfc_expr_attr (target).proc_pointer)
{
- gfc_error ("Associating entity %qs at %L is a procedure name",
+ gfc_error ("Associating entity %qs at %L is a procedure pointer",
tsym->name, &target->where);
return;
}
- if (gfc_expr_attr (target).proc_pointer)
+ if (tsym->attr.flavor == FL_PROCEDURE && tsym->generic
+ && (dsym = gfc_find_dt_in_generic (tsym)) != NULL
+ && dsym->attr.flavor == FL_DERIVED)
{
- gfc_error ("Associating entity %qs at %L is a procedure pointer",
+ gfc_error ("Derived type %qs cannot be used as a variable at %L",
tsym->name, &target->where);
return;
}
+ if (tsym->attr.flavor == FL_PROCEDURE)
+ {
+ bool is_error = true;
+ if (tsym->attr.function && tsym->result == tsym)
+ for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent)
+ if (tsym == ns->proc_name)
+ {
+ is_error = false;
+ break;
+ }
+ if (is_error)
+ {
+ gfc_error ("Associating entity %qs at %L is a procedure name",
+ tsym->name, &target->where);
+ return;
+ }
+ }
+
sym->attr.asynchronous = tsym->attr.asynchronous;
sym->attr.volatile_ = tsym->attr.volatile_;
diff --git a/gcc/testsuite/gfortran.dg/associate_51.f90 b/gcc/testsuite/gfortran.dg/associate_51.f90
index b6ab1414b02..e6f2e4fafa3 100644
--- a/gcc/testsuite/gfortran.dg/associate_51.f90
+++ b/gcc/testsuite/gfortran.dg/associate_51.f90
@@ -29,7 +29,7 @@ subroutine p2
type t
end type
type(t) :: z = t()
- associate (y => t)
+ associate (y => t())
end associate
end
diff --git a/gcc/testsuite/gfortran.dg/associate_53.f90 b/gcc/testsuite/gfortran.dg/associate_53.f90
new file mode 100644
index 00000000000..5b56af38e47
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_53.f90
@@ -0,0 +1,71 @@
+! { dg-do compile }
+!
+! PR fortran/93363
+!
+! Contributed by G. Steinmetz
+
+program p
+ type t
+ integer :: a
+ end type
+ type(t) :: z
+ z = t(1)
+ associate (var1 => t) ! { dg-error "Derived type 't' cannot be used as a variable" }
+ end associate
+end
+
+subroutine sub
+ if (f() /= 1) stop
+ associate (var2 => f) ! { dg-error "Associating entity 'f' at .1. is a procedure name" }
+ end associate
+ block
+ block
+ associate (var2a => f) ! { dg-error "Associating entity 'f' at .1. is a procedure name" }
+ end associate
+ end block
+ end block
+contains
+ integer function f()
+ f = 1
+ associate (var3 => f)
+ end associate
+ block
+ block
+ associate (var4 => f)
+ end associate
+ end block
+ end block
+ end
+ integer recursive function f2() result(res)
+ res = 1
+ associate (var5 => f2) ! { dg-error "Associating entity 'f2' at .1. is a procedure name" }
+ end associate
+ block
+ block
+ associate (var6 => f2) ! { dg-error "Associating entity 'f2' at .1. is a procedure name" }
+ end associate
+ end block
+ end block
+ end
+ subroutine subsub
+ associate (var7 => f) ! { dg-error "Associating entity 'f' at .1. is a procedure name" }
+ end associate
+ block
+ block
+ associate (var8 => f) ! { dg-error "Associating entity 'f' at .1. is a procedure name" }
+ end associate
+ end block
+ end block
+ end
+end
+
+subroutine sub2
+ interface g
+ procedure s
+ end interface
+ associate (var9 => g) ! { dg-error "Associating entity 'g' at .1. is a procedure name" }
+ end associate
+contains
+ subroutine s
+ end
+end
