Dear All, the attached patch fixes the INTENT(IN) checks for ASSOCIATE variables and also SELECT TYPE temporaries. Before we did reject valid codes involving pointer components of derived types, where plain assignment is allowed, but changing the pointer is not.
While working on it, I noticed that the related checking of PROTECTED did not properly handle subobjects. This required fixing a related existing testcase. Regtested on x86_64-pc-linux-gnu. OK for mainline? Thanks, Harald
From 05f9824f44f088f4afa02f03063d638c787162c5 Mon Sep 17 00:00:00 2001 From: Harald Anlauf <[email protected]> Date: Fri, 19 Dec 2025 21:15:44 +0100 Subject: [PATCH] Fortran: INTENT(IN) polymorphic argument with pointer components [PR71565] PR fortran/71565 gcc/fortran/ChangeLog: * expr.cc (gfc_check_vardef_context): Fix treatment of INTENT(IN) checks for ASSOCIATE variables. Correct checking of PROTECTED objects, as subobjects inherit the PROTECTED attribute. gcc/testsuite/ChangeLog: * gfortran.dg/protected_8.f90: Adjust patterns. * gfortran.dg/associate_76.f90: New test. --- gcc/fortran/expr.cc | 33 ++++++++--- gcc/testsuite/gfortran.dg/associate_76.f90 | 67 ++++++++++++++++++++++ gcc/testsuite/gfortran.dg/protected_8.f90 | 6 +- 3 files changed, 95 insertions(+), 11 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/associate_76.f90 diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index 054276e86b1..d8d9009dc42 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -6757,7 +6757,10 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer; for (ref = e->ref; ref && check_intentin; ref = ref->next) { - if (ptr_component && ref->type == REF_COMPONENT) + /* Associate-targets need special handling. Subobjects of an object with + the PROTECTED attribute inherit this attribute. */ + if (ptr_component && ref->type == REF_COMPONENT + && !sym->assoc && !sym->attr.is_protected) check_intentin = false; if (ref->type == REF_COMPONENT) { @@ -6780,24 +6783,34 @@ 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->attr.intent == INTENT_IN || (sym->attr.select_type_temporary && sym->assoc && sym->assoc->target && sym->assoc->target->symtree && sym->assoc->target->symtree->n.sym->attr.intent == INTENT_IN))) { + const char *name = (sym->attr.select_type_temporary + ? sym->assoc->target->symtree->name : sym->name); if (pointer && is_pointer) { if (context) gfc_error ("Dummy argument %qs with INTENT(IN) in pointer" " association context (%s) at %L", - sym->name, context, &e->where); + name, context, &e->where); return false; } if (!pointer && !is_pointer && !sym->attr.pointer) { - const char *name = sym->attr.select_type_temporary - ? sym->assoc->target->symtree->name : sym->name; if (context) gfc_error ("Dummy argument %qs with INTENT(IN) in variable" " definition context (%s) at %L", @@ -6810,7 +6823,8 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, if (sym->attr.is_protected && (sym->attr.use_assoc || (sym->attr.used_in_submodule && !sym_is_from_ancestor (sym))) - && check_intentin) + && !own_scope + && (check_intentin || !pointer)) { if (pointer && is_pointer) { @@ -6863,7 +6877,8 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, } } /* Check variable definition context for associate-names. */ - if (!pointer && sym->assoc && !sym->attr.select_rank_temporary) + if ((!pointer || check_intentin) + && sym->assoc && !sym->attr.select_rank_temporary) { const char* name; gfc_association_list* assoc; @@ -6927,8 +6942,10 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, } } - /* Target must be allowed to appear in a variable definition context. */ - if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL)) + /* Target must be allowed to appear in a variable definition context. + Check valid assignment to pointers and invalid reassociations. */ + if (!gfc_check_vardef_context (assoc->target, pointer, false, false, NULL) + && (!ptr_component || pointer)) { if (context) gfc_error ("Associate-name %qs cannot appear in a variable" diff --git a/gcc/testsuite/gfortran.dg/associate_76.f90 b/gcc/testsuite/gfortran.dg/associate_76.f90 new file mode 100644 index 00000000000..d76c052703e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_76.f90 @@ -0,0 +1,67 @@ +! { dg-do compile } +! PR fortran/71565 - INTENT(IN) polymorphic argument with pointer components +! +! Contributed by Marco Restelli. + +module m + implicit none + + type, abstract :: t_a + end type t_a + + type, extends(t_a), abstract :: t_b + integer, pointer :: i => null() + end type t_b + +contains + + subroutine s1(var) + class(t_a), intent(in) :: var + select type(var) + class is(t_b) + var%i = 3 + var%i => NULL() ! { dg-error "pointer association context" } + end select + end subroutine s1 + + subroutine s1a(var) + class(t_a), intent(in) :: var + select type(tmp => var) ! { dg-error "variable definition context" } + class is(t_b) + tmp%i = 3 + tmp%i => NULL() ! { dg-error "variable definition context" } + end select + end subroutine s1a + + subroutine s2(var) + class(t_b), intent(in) :: var + var%i = 3 + var%i => NULL() ! { dg-error "pointer association context" } + end subroutine s2 + + subroutine s2a(var) + class(t_b), intent(in) :: var + associate (tmp => var) ! { dg-error "variable definition context" } + print *, associated (tmp%i) + tmp%i = 3 + tmp%i => NULL() ! { dg-error "variable definition context" } + end associate + end subroutine s2a + + subroutine s2b(var) + class(t_b), intent(in) :: var + associate (tmp => var%i) + tmp = 3 + end associate + end subroutine s2b + + subroutine s3(var) + class(t_a), intent(in) :: var + integer, pointer :: tmp + select type(var); class is(t_b) + tmp => var%i + tmp = 3 + end select + end subroutine s3 + +end module m diff --git a/gcc/testsuite/gfortran.dg/protected_8.f90 b/gcc/testsuite/gfortran.dg/protected_8.f90 index 7e02044720d..dfd0625bd40 100644 --- a/gcc/testsuite/gfortran.dg/protected_8.f90 +++ b/gcc/testsuite/gfortran.dg/protected_8.f90 @@ -41,8 +41,8 @@ PROGRAM test a%j => k ! { dg-error "is PROTECTED" } a%j = 5 ! OK 2 b => c ! { dg-error "is PROTECTED" } - b%i = k ! OK 3 - b%j => k ! OK 4 - b%j = 5 ! OK 5 + b%i = k ! { dg-error "is PROTECTED" } + b%j => k ! { dg-error "is PROTECTED" } + b%j = 5 ! OK 3 END PROGRAM test -- 2.51.0
