Dear all, this patch addresses the issue that a procedure may appear in a derived-type constructor as target of a procedure pointer. Adjusting check_constructor solves the rejects-valid.
While working on an extended testcase, I found that there is a resolution issue in gfortran when trying to use dispatch tables that are named constants (i.e., PARAMETER). I have not yet been able to locate where the difference between dynamic and static tables leads to different resolution, and decided to add all variants to the testcase with the wrongly rejected cases commented out. Note that the full testcase works with NAG. I propose to commit the attached variant and leave the PR open until the resolution issue is fixed or the PR is replaced by a more appropriate one. Regtested on x86_64-pc-linux-gnu. OK for mainline? Thanks, Harald
From 7b3db15efee0107f41efe1117c6ff1219eac9128 Mon Sep 17 00:00:00 2001 From: Harald Anlauf <[email protected]> Date: Thu, 13 Nov 2025 22:34:03 +0100 Subject: [PATCH] Fortran: procedure targets in derived-type constructors [PR117070] PR fortran/117070 gcc/fortran/ChangeLog: * array.cc (check_constructor): Allow procedures as potential target of a procedure pointer. gcc/testsuite/ChangeLog: * gfortran.dg/proc_target_1.f90: New test. --- gcc/fortran/array.cc | 6 + gcc/testsuite/gfortran.dg/proc_target_1.f90 | 134 ++++++++++++++++++++ 2 files changed, 140 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/proc_target_1.f90 diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc index 8f0004992e8..57a7b134e4c 100644 --- a/gcc/fortran/array.cc +++ b/gcc/fortran/array.cc @@ -1644,6 +1644,12 @@ check_constructor (gfc_constructor_base ctor, bool (*check_function) (gfc_expr * if (!e) continue; + /* Allow procedures as potential target of a procedure pointer. */ + if (e->expr_type == EXPR_VARIABLE + && e->ts.type == BT_PROCEDURE + && e->symtree->n.sym->attr.flavor == FL_PROCEDURE) + continue; + if (e->expr_type != EXPR_ARRAY) { if (!(*check_function)(e)) diff --git a/gcc/testsuite/gfortran.dg/proc_target_1.f90 b/gcc/testsuite/gfortran.dg/proc_target_1.f90 new file mode 100644 index 00000000000..050ee39a7d0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/proc_target_1.f90 @@ -0,0 +1,134 @@ +! { dg-do run } +! +! PR fortran/117070 - Procedure targets in derived-type constructors +! +! Contributed by Ivan Pribec + +module funcs + implicit none + + abstract interface + function retchar() + character(len=1) :: retchar + end function retchar + end interface +contains + function a() + character(len=1) :: a + a = 'a' + end function + function b() + character(len=1) :: b + b = 'b' + end function + function c() + character(len=1) :: c + c = 'c' + end function +end module + +module dispatch_table + use funcs + implicit none + + ! Procedure container + type :: pc + procedure(retchar), pointer, nopass :: rc => null() + end type pc + + type(pc), parameter :: dtab_p(3) = [pc(a),pc(b),pc(c)] ! Parameter + type(pc) :: dtab_v(3) = [pc(a),pc(b),pc(c)] ! Variable + +contains + + ! Dynamic dispatch table + function build_table() result(table) + type(pc) :: table(3) + table = [pc(a),pc(b),pc(c)] + end function build_table + +end module + +program test + use dispatch_table + implicit none + type(pc), parameter :: table_p(3) = [pc(a),pc(b),pc(c)] ! Parameter + type(pc) :: table_v(3) = [pc(a),pc(b),pc(c)] ! Variable + type(pc) :: table(3) + + ! Get dispatch table from local variable + table = table_v + associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) + if (abc /= 'abc') stop 1 + end associate + + associate (abc => table_v(1)%rc()//table_v(2)%rc()//table_v(3)%rc()) + if (abc /= 'abc') stop 2 + end associate + + table = table_p + associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) + if (abc /= 'abc') stop 3 + end associate + +! Bogus error: +! "Operands of string concatenation operator at (1) are PROCEDURE/PROCEDURE" +! associate (abc => table_p(1)%rc()//table_p(2)%rc()//table_p(3)%rc()) +! if (abc /= 'abc') stop 4 +! end associate + + ! Get dispatch table from other module and passed via local variable + table = build_table() ! Dynamic table + associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) + if (abc /= 'abc') stop 5 + end associate + + table = dtab_v + associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) + if (abc /= 'abc') stop 6 + end associate + + table = dtab_p + associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) + if (abc /= 'abc') stop 7 + end associate + + ! Dispatch table from other module directly used in associate + associate (abc => dtab_v(1)%rc()//dtab_v(2)%rc()//dtab_v(3)%rc()) + if (abc /= 'abc') stop 8 + end associate + +! associate (abc => dtab_p(1)%rc()//dtab_p(2)%rc()//dtab_p(3)%rc()) +! if (abc /= 'abc') stop 9 +! end associate + + ! Several variations + block + type(pc) :: table(3) = [pc(a),pc(b),pc(c)] + associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) + if (abc /= 'abc') stop 10 + end associate + end block + + block + use dispatch_table, only: table => dtab_v + associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) + if (abc /= 'abc') stop 11 + end associate + end block + +! block +! type(pc), parameter :: table(3) = [pc(a),pc(b),pc(c)] +! associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) +! if (abc /= 'abc') stop 12 +! end associate +! end block + +! block +! use dispatch_table, only: table => dtab_p +! associate (abc => table(1)%rc()//table(2)%rc()//table(3)%rc()) +! if (abc /= 'abc') stop 13 +! end associate +! end block + +end program -- 2.51.0
