[gcc r13-7146] Fortran: fix functions with entry and pointer/allocatable result [PR104312]

[gcc r13-7146] Fortran: fix functions with entry and pointer/allocatable result [PR104312]

[Harald Anlauf]

https://gcc.gnu.org/g:2273fd5a6fdbe8f7da2c0e217c279bcbaaa7df9e

commit r13-7146-g2273fd5a6fdbe8f7da2c0e217c279bcbaaa7df9e
Author: Harald Anlauf <anlauf@gmx.de>
Date:   Tue Apr 11 21:44:20 2023 +0200

    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.

Diff:
---
 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(-)

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