Fortran: Fix wrong recursive errors and class initialization [PR112407]

2024-04-02  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/112407
	* resolve.cc (resolve_procedure_expression): Change the test for
	for recursion in the case of hidden procedures from modules.
	(resolve_typebound_static): Add warning for possible recursive
	calls to typebound procedures.
	* trans-expr.cc (gfc_trans_class_init_assign): Do not apply
	default initializer to class dummy where component initializers
	are all null.

gcc/testsuite/
	PR fortran/112407
	* gfortran.dg/pr112407a.f90: New test.
	* gfortran.dg/pr112407b.f90: New test.

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 50d51b06c928f6276885f57fae2269f0eabe4514..43315a6a550e9f0540c494047729b6b0142eed04 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -1963,12 +1963,20 @@ resolve_procedure_expression (gfc_expr* expr)
       || (sym->attr.function && sym->result == sym))
     return true;
 
-  /* A non-RECURSIVE procedure that is used as procedure expression within its
+   /* A non-RECURSIVE procedure that is used as procedure expression within its
      own body is in danger of being called recursively.  */
   if (is_illegal_recursion (sym, gfc_current_ns))
-    gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
-                " itself recursively.  Declare it RECURSIVE or use"
-                " %<-frecursive%>", sym->name, &expr->where);
+    {
+      if (sym->attr.use_assoc && expr->symtree->name[0] == '@')
+       gfc_warning (0, "Non-RECURSIVE procedure %qs from module %qs is "
+                    " possibly calling itself recursively in procedure %qs. "
+                    " Declare it RECURSIVE or use %<-frecursive%>",
+                    sym->name, sym->module, gfc_current_ns->proc_name->name);
+      else
+       gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
+                    " itself recursively.  Declare it RECURSIVE or use"
+                    " %<-frecursive%>", sym->name, &expr->where);
+    }
 
   return true;
 }
@@ -6820,6 +6828,13 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
       if (st)
        *target = st;
     }
+
+  if (is_illegal_recursion ((*target)->n.sym, gfc_current_ns)
+      && !e->value.compcall.tbp->deferred)
+    gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling"
+                " itself recursively.  Declare it RECURSIVE or use"
+                " %<-frecursive%>", (*target)->n.sym->name, &e->where);
+
   return true;
 }
 

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index d21e3956d6e7aae7e057e8d27f64bd5b687bf261..f4c4724e1c3e6898841e786f77c0801b2513ed5e 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1719,6 +1719,7 @@ gfc_trans_class_init_assign (gfc_code *code)
   tree tmp;
   gfc_se dst,src,memsz;
   gfc_expr *lhs, *rhs, *sz;
+  gfc_component *cmp;
 
   gfc_start_block (&block);
 
@@ -1735,6 +1736,21 @@ gfc_trans_class_init_assign (gfc_code *code)
   /* The _def_init is always scalar.  */
   rhs->rank = 0;
 
+  /* Check def_init for initializers.  If this is a dummy with all default
+     initializer components NULL, return NULL_TREE and use the passed value as
+     required by F2018(8.5.10).  */
+  if (!lhs->ref && lhs->symtree->n.sym->attr.dummy)
+    {
+      cmp = rhs->ref->next->u.c.component->ts.u.derived->components;
+      for (; cmp; cmp = cmp->next)
+       {
+         if (cmp->initializer)
+           break;
+         else if (!cmp->next)
+           return build_empty_stmt (input_location);
+       }
+    }
+
   if (code->expr1->ts.type == BT_CLASS
       && CLASS_DATA (code->expr1)->attr.dimension)
     {

diff --git a/gcc/testsuite/gfortran.dg/pr112407a.f90 b/gcc/testsuite/gfortran.dg/pr112407a.f90
new file mode 100644 (file)
index 0000000..470f419
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr112407a.f90
@@ -0,0 +1,71 @@
+! { dg-do run }
+! Test of an issue found in the investigation of PR112407
+! Contributed by Tomas Trnka  <trnka@scm.com>
+!
+module m
+  private new_t
+
+  type s
+    procedure(),pointer,nopass :: op
+  end type
+
+  type :: t
+    integer :: i
+    type (s) :: s
+  contains
+    procedure :: new_t
+    procedure :: bar
+    procedure :: add_t
+    generic :: new => new_t, bar
+    generic, public :: assignment(=) => add_t
+    final :: final_t
+  end type
+
+  integer :: i = 0, finals = 0
+
+contains
+  recursive subroutine new_t (arg1, arg2)
+    class(t), intent(out) :: arg1
+    type(t), intent(in)  :: arg2
+    i = i + 1
+
+    print "(a,2i4)", "new_t", arg1%i, arg2%i
+    if (i .ge. 10) return
+
+! According to F2018(8.5.10), arg1 should be undefined on invocation, unless
+! any sub-components are default initialised. gfc used to set arg1%i = 0.
+    if (arg1%i .ne. arg2%i) then
+      arg1%i = arg2%i
+      call arg1%new(arg2)
+    endif
+  end
+
+  subroutine bar(arg)
+    class(t), intent(out) :: arg
+    call arg%new(t(42, s(new_t)))
+  end
+
+  subroutine add_t (arg1, arg2)
+    class(t), intent(out) :: arg1
+    type(t), intent(in)  :: arg2
+    call arg1%new (arg2)
+  end
+
+  impure elemental subroutine final_t (arg1)
+    type(t), intent(in) :: arg1
+    finals = finals + 1
+  end
+end
+
+  use m
+  class(t), allocatable :: x
+  allocate(x)
+  x%i = 0
+  call x%new()                   ! gfortran used to output 10*'new_t'
+  print "(3i4)", x%i, i, finals  !           -||-          0 10 11
+!
+! The other brands output 2*'new_t' + 42 2 3 and now so does gfc :-)
+  if (x%i .ne. 42) stop 1
+  if (i .ne. 2) stop 2
+  if (finals .ne. 3) stop 3
+end

diff --git a/gcc/testsuite/gfortran.dg/pr112407b.f90 b/gcc/testsuite/gfortran.dg/pr112407b.f90
new file mode 100644 (file)
index 0000000..b4653f8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr112407b.f90
@@ -0,0 +1,58 @@
+! { dg-do compile }
+! { dg-options "-std=f2008" }
+! Test of an issue found in the investigation of PR112407. The dg-option is
+! set to avoid regression once the F2018 RECURSIVE by default in implemented.
+! Contributed by Tomas Trnka  <trnka@scm.com>
+!
+module m
+  private new_t
+
+  type s
+    procedure(),pointer,nopass :: op
+  end type
+
+  type :: t
+    integer :: i
+    type (s) :: s
+  contains
+    procedure :: new_t
+    procedure :: bar
+    procedure :: add_t
+    generic :: new => new_t, bar
+    generic, public :: assignment(=) => add_t
+    final :: final_t
+  end type
+
+  integer :: i = 0, finals = 0
+
+contains
+  subroutine new_t (arg1, arg2)            ! gfortran didn't detect the recursion
+    class(t), intent(out) :: arg1
+    type(t), intent(in)  :: arg2
+    i = i + 1
+
+    print *, "new_t", arg1%i, arg2%i
+    if (i .ge. 10) return
+
+    if (arg1%i .ne. arg2%i) then
+      arg1%i = arg2%i
+      call arg1%new(arg2)  ! { dg-warning "possibly calling itself recursively" }
+    endif
+  end
+
+  subroutine bar(arg)
+    class(t), intent(out) :: arg
+    call arg%new(t(42, s(new_t)))
+  end
+
+  subroutine add_t (arg1, arg2)
+    class(t), intent(out) :: arg1
+    type(t), intent(in)  :: arg2
+    call arg1%new (arg2)
+  end
+
+  impure elemental subroutine final_t (arg1)
+    type(t), intent(in) :: arg1
+    finals = finals + 1
+  end
+end