From a76ff304f905db9fd9b049c2ca4ec84f0420da53 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Fri, 27 Mar 2020 10:56:25 +0100 Subject: [PATCH] Fortran] Reject invalid association target (PR93363) 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/ChangeLog | 6 ++ gcc/fortran/resolve.c | 32 +++++++--- gcc/testsuite/ChangeLog | 6 ++ gcc/testsuite/gfortran.dg/associate_51.f90 | 2 +- gcc/testsuite/gfortran.dg/associate_53.f90 | 71 ++++++++++++++++++++++ 5 files changed, 109 insertions(+), 8 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/associate_53.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0f6dab3b3c2..39aa22df298 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2020-03-27 Tobias Burnus + + PR fortran/93363 + * resolve.c (resolve_assoc_var): Reject association to DT and + function name. + 2020-03-25 Steven G. Kargl PR fortran/93484 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/ChangeLog b/gcc/testsuite/ChangeLog index 5f9b164d486..8107f008999 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2020-03-27 Tobias Burnus + + PR fortran/93363 + * gfortran.dg/associate_51.f90: Fix test case. + * gfortran.dg/associate_53.f90: New. + 2020-03-27 Jakub Jelinek PR c++/94326 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 -- 2.30.2