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 --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 6e42397..58013d4 100644 (file)
--- 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 f052d6b..79367fa 100644 (file)
--- 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 9c9489a..fc5c221 100644 (file)
--- 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 (file)
index 0000000..018aedc
--- /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 (file)
index 0000000..f1e28fd
--- /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