From 60e81b97cf3715347de30ed4fd579be54fdb1997 Mon Sep 17 00:00:00 2001 From: Harald Anlauf Date: Tue, 11 Apr 2023 21:44:20 +0200 Subject: [PATCH] Fortran: fix functions with entry and pointer/allocatable result [PR104312] gcc/fortran/ChangeLog: PR fortran/104312 * resolve.cc (resolve_entries): Handle functions with ENTRY and ALLOCATABLE results. * trans-expr.cc (gfc_conv_procedure_call): Functions with a result with the POINTER or ALLOCATABLE attribute shall not get any special treatment with -ff2c, as they cannot be written in Fortran 77. * trans-types.cc (gfc_return_by_reference): Likewise. (gfc_get_function_type): Likewise. gcc/testsuite/ChangeLog: PR fortran/104312 * gfortran.dg/entry_26.f90: New test. * gfortran.dg/entry_27.f90: New test. --- gcc/fortran/resolve.cc | 19 +++++++- gcc/fortran/trans-expr.cc | 2 + gcc/fortran/trans-types.cc | 4 ++ gcc/testsuite/gfortran.dg/entry_26.f90 | 64 ++++++++++++++++++++++++++ gcc/testsuite/gfortran.dg/entry_27.f90 | 64 ++++++++++++++++++++++++++ 5 files changed, 152 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/entry_26.f90 create mode 100644 gcc/testsuite/gfortran.dg/entry_27.f90 diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 6e42397c2ea..58013d48dff 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -702,7 +702,8 @@ resolve_entries (gfc_namespace *ns) gfc_code *c; gfc_symbol *proc; gfc_entry_list *el; - char name[GFC_MAX_SYMBOL_LEN + 1]; + /* Provide sufficient space to hold "master.%d.%s". */ + char name[GFC_MAX_SYMBOL_LEN + 1 + 18]; static int master_count = 0; if (ns->proc_name == NULL) @@ -827,6 +828,9 @@ resolve_entries (gfc_namespace *ns) "entries returning variables of different " "string lengths", ns->entries->sym->name, &ns->entries->sym->declared_at); + else if (el->sym->result->attr.allocatable + != ns->entries->sym->result->attr.allocatable) + break; } if (el == NULL) @@ -838,6 +842,8 @@ resolve_entries (gfc_namespace *ns) gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL); if (sym->attr.pointer) gfc_add_pointer (&proc->attr, NULL); + if (sym->attr.allocatable) + gfc_add_allocatable (&proc->attr, NULL); } else { @@ -869,6 +875,17 @@ resolve_entries (gfc_namespace *ns) "FUNCTION %s at %L", sym->name, ns->entries->sym->name, &sym->declared_at); } + else if (sym->attr.allocatable) + { + if (el == ns->entries) + gfc_error ("FUNCTION result %s cannot be ALLOCATABLE in " + "FUNCTION %s at %L", sym->name, + ns->entries->sym->name, &sym->declared_at); + else + gfc_error ("ENTRY result %s cannot be ALLOCATABLE in " + "FUNCTION %s at %L", sym->name, + ns->entries->sym->name, &sym->declared_at); + } else { ts = &sym->ts; diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index f052d6b9440..79367fa2ae0 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -7800,6 +7800,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, */ if (flag_f2c && sym->ts.type == BT_REAL && sym->ts.kind == gfc_default_real_kind + && !sym->attr.pointer + && !sym->attr.allocatable && !sym->attr.always_explicit) se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr); diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index 9c9489a42bd..fc5c221a301 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -2962,6 +2962,8 @@ gfc_return_by_reference (gfc_symbol * sym) require an explicit interface, as no compatibility problems can arise there. */ if (flag_f2c && sym->ts.type == BT_COMPLEX + && !sym->attr.pointer + && !sym->attr.allocatable && !sym->attr.intrinsic && !sym->attr.always_explicit) return 1; @@ -3273,6 +3275,8 @@ arg_type_list_done: type = gfc_get_mixed_entry_union (sym->ns); else if (flag_f2c && sym->ts.type == BT_REAL && sym->ts.kind == gfc_default_real_kind + && !sym->attr.pointer + && !sym->attr.allocatable && !sym->attr.always_explicit) { /* Special case: f2c calling conventions require that (scalar) diff --git a/gcc/testsuite/gfortran.dg/entry_26.f90 b/gcc/testsuite/gfortran.dg/entry_26.f90 new file mode 100644 index 00000000000..018aedc7854 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/entry_26.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! { dg-additional-options "-fno-f2c" } +! +! PR fortran/104312 - ICE in fold_convert_loc with entry, -ff2c: control +! Contributed by G.Steinmetz + +module m + implicit none +contains + function f() + real, pointer :: f, e + real, target :: a(2) = [1,2] + f => a(1) + return + entry e() + e => a(2) + end + function g() + complex, pointer :: g,h + complex, target :: a(2) = [3,4] + g => a(1) + return + entry h() + h => a(2) + end + function f3() + real, allocatable :: f3, e3 + allocate (f3, source=1.0) + return + entry e3() + allocate (e3, source=2.0) + end + function g3() + complex, allocatable :: g3, h3 + allocate (g3, source=(3.0,0.0)) + return + entry h3() + allocate (h3, source=(4.0,0.0)) + end +end + +program p + use m + real, pointer :: x + complex, pointer :: c + real :: y + complex :: d + x => f() + if (x /= 1.0) stop 1 + x => e() + if (x /= 2.0) stop 2 + c => g() + if (c /= (3.0,0.0)) stop 3 + c => h() + if (c /= (4.0,0.0)) stop 4 + y = f3() + if (y /= 1.0) stop 5 + y = e3() + if (y /= 2.0) stop 6 + d = g3() + if (d /= (3.0,0.0)) stop 7 + d = h3() + if (d /= (4.0,0.0)) stop 8 +end diff --git a/gcc/testsuite/gfortran.dg/entry_27.f90 b/gcc/testsuite/gfortran.dg/entry_27.f90 new file mode 100644 index 00000000000..f1e28fda935 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/entry_27.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! { dg-additional-options "-ff2c" } +! +! PR fortran/104312 - ICE in fold_convert_loc with entry, -ff2c: test +! Contributed by G.Steinmetz + +module m + implicit none +contains + function f() + real, pointer :: f, e + real, target :: a(2) = [1,2] + f => a(1) + return + entry e() + e => a(2) + end + function g() + complex, pointer :: g,h + complex, target :: a(2) = [3,4] + g => a(1) + return + entry h() + h => a(2) + end + function f3() + real, allocatable :: f3, e3 + allocate (f3, source=1.0) + return + entry e3() + allocate (e3, source=2.0) + end + function g3() + complex, allocatable :: g3, h3 + allocate (g3, source=(3.0,0.0)) + return + entry h3() + allocate (h3, source=(4.0,0.0)) + end +end + +program p + use m + real, pointer :: x + complex, pointer :: c + real :: y + complex :: d + x => f() + if (x /= 1.0) stop 1 + x => e() + if (x /= 2.0) stop 2 + c => g() + if (c /= (3.0,0.0)) stop 3 + c => h() + if (c /= (4.0,0.0)) stop 4 + y = f3() + if (y /= 1.0) stop 5 + y = e3() + if (y /= 2.0) stop 6 + d = g3() + if (d /= (3.0,0.0)) stop 7 + d = h3() + if (d /= (4.0,0.0)) stop 8 +end -- 2.35.3