https://gcc.gnu.org/g:4fa9ce0b7d1ac1e495a2ec7a6934ef1be5b74cbb
commit r16-5274-g4fa9ce0b7d1ac1e495a2ec7a6934ef1be5b74cbb Author: Harald Anlauf <[email protected]> Date: Thu Nov 13 22:34:03 2025 +0100 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. Diff: --- gcc/fortran/array.cc | 6 ++ gcc/testsuite/gfortran.dg/proc_target_1.f90 | 134 ++++++++++++++++++++++++++++ 2 files changed, 140 insertions(+) diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc index 8f0004992e81..57a7b134e4c2 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 000000000000..050ee39a7d00 --- /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
