https://gcc.gnu.org/g:692ca18d491ec2337f50a1788866106dcb597901
commit r16-6341-g692ca18d491ec2337f50a1788866106dcb597901 Author: Harald Anlauf <[email protected]> Date: Mon Dec 22 21:05:29 2025 +0100 Fortran: fix variable definition context checks for SELECT TYPE [PR123253] Commit r16-6300 introduced a regression when checking the variable definition context of SELECT TYPE variables where the selector was not a dummy argument as the scan for the association target was too shallow. Scan through association lists for the ultimate selector. PR fortran/123253 gcc/fortran/ChangeLog: * expr.cc (gfc_check_vardef_context): Replace simple check by a scan through the association targets for a dummy argument. gcc/testsuite/ChangeLog: * gfortran.dg/associate_76.f90: Extended testcase. * gfortran.dg/associate_77.f90: New test. Diff: --- gcc/fortran/expr.cc | 33 +++++++++++---- gcc/testsuite/gfortran.dg/associate_76.f90 | 38 ++++++++++++++++- gcc/testsuite/gfortran.dg/associate_77.f90 | 65 ++++++++++++++++++++++++++++++ 3 files changed, 127 insertions(+), 9 deletions(-) diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index d8d9009dc426..87587ee2010c 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -6784,14 +6784,31 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, } /* See if the INTENT(IN) check should apply to an ASSOCIATE target. */ - if (check_intentin - && sym->assoc - && sym->assoc->target - && sym->assoc->target->symtree - && sym->assoc->target->symtree->n.sym - && sym->assoc->target->symtree->n.sym->attr.dummy - && sym->assoc->target->symtree->n.sym->attr.intent != INTENT_IN) - check_intentin = false; + if (check_intentin && sym->assoc && sym->assoc->target) + { + gfc_expr *target; + gfc_symbol *tsym; + + check_intentin = false; + + /* Walk through associate target chain to find a dummy argument. */ + for (target = sym->assoc->target; target; target = tsym->assoc->target) + { + tsym = target->symtree ? target->symtree->n.sym : NULL; + + if (tsym == NULL) + break; + + if (tsym->attr.dummy) + { + check_intentin = (tsym->attr.intent == INTENT_IN); + break; + } + + if (tsym->assoc == NULL) + break; + } + } if (check_intentin && (sym->attr.intent == INTENT_IN diff --git a/gcc/testsuite/gfortran.dg/associate_76.f90 b/gcc/testsuite/gfortran.dg/associate_76.f90 index d76c052703e8..7f1023fd19f8 100644 --- a/gcc/testsuite/gfortran.dg/associate_76.f90 +++ b/gcc/testsuite/gfortran.dg/associate_76.f90 @@ -22,6 +22,14 @@ contains var%i = 3 var%i => NULL() ! { dg-error "pointer association context" } end select + + associate (avar => var) + select type(avar) ! { dg-error "variable definition context" } + class is(t_b) + avar%i = 3 + avar%i => NULL() ! { dg-error "variable definition context" } + end select + end associate end subroutine s1 subroutine s1a(var) @@ -31,8 +39,27 @@ contains tmp%i = 3 tmp%i => NULL() ! { dg-error "variable definition context" } end select + + associate (avar => var) + select type(tmp => avar) ! { dg-error "variable definition context" } + class is(t_b) + tmp%i = 3 + tmp%i => NULL() ! { dg-error "variable definition context" } + end select + end associate end subroutine s1a + subroutine s1b(var) + class(t_a), intent(in) :: var + associate (avar => var) + select type(tmp => avar) ! { dg-error "variable definition context" } + class is(t_b) + tmp%i = 3 + tmp%i => NULL() ! { dg-error "variable definition context" } + end select + end associate + end subroutine s1b + subroutine s2(var) class(t_b), intent(in) :: var var%i = 3 @@ -58,10 +85,19 @@ contains subroutine s3(var) class(t_a), intent(in) :: var integer, pointer :: tmp - select type(var); class is(t_b) + select type(var) + class is(t_b) tmp => var%i tmp = 3 end select + + associate (avar => var) + select type(avar) + class is(t_b) + tmp => avar%i + tmp = 3 + end select + end associate end subroutine s3 end module m diff --git a/gcc/testsuite/gfortran.dg/associate_77.f90 b/gcc/testsuite/gfortran.dg/associate_77.f90 new file mode 100644 index 000000000000..6e80595711f2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_77.f90 @@ -0,0 +1,65 @@ +! { dg-do compile } +! PR fortran/123253 - pointer assignment checks in SELECT TYPE +! +! Contributed by Jürgen Reuter + +module vamp + implicit none + private + type, public :: vamp_data_t + end type vamp_data_t +end module vamp + +module mci_vamp + use vamp !NODEP! + implicit none + private + + type, abstract :: mci_sampler_t + end type mci_sampler_t + + type :: mci_vamp_t + contains + procedure :: generate_weighted_event => mci_vamp_generate_weighted_event + end type mci_vamp_t + + type, extends (vamp_data_t) :: mci_workspace_t + class(mci_sampler_t), pointer :: sampler => null () + class(mci_vamp_instance_t), pointer :: instance => null () + end type mci_workspace_t + + type :: mci_vamp_instance_t + type(mci_vamp_t), pointer :: mci => null () + end type mci_vamp_instance_t + +contains + + subroutine mci_vamp_generate_weighted_event (mci, instance, sampler) + class(mci_vamp_t), intent(inout) :: mci + class(mci_vamp_instance_t), intent(inout), target :: instance + class(mci_sampler_t), intent(inout), target :: sampler + class(vamp_data_t), allocatable :: data + + select type (instance) + type is (mci_vamp_instance_t) + allocate (mci_workspace_t :: data) + select type (data) + type is (mci_workspace_t) + data%sampler => sampler + data%instance => instance + end select + end select + + select type (foo_instance => instance) + type is (mci_vamp_instance_t) + allocate (mci_workspace_t :: data) + select type (tmp => data) + type is (mci_workspace_t) + tmp%sampler => sampler + tmp%instance => foo_instance + end select + end select + + end subroutine mci_vamp_generate_weighted_event + +end module mci_vamp
