https://gcc.gnu.org/g:05f9824f44f088f4afa02f03063d638c787162c5
commit r16-6300-g05f9824f44f088f4afa02f03063d638c787162c5 Author: Harald Anlauf <[email protected]> Date: Fri Dec 19 21:15:44 2025 +0100 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. Diff: --- 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(-) diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index 054276e86b1f..d8d9009dc426 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 000000000000..d76c052703e8 --- /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 7e02044720de..dfd0625bd408 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
