Fortran: Fix ICEs due to comp calls in initialization exprs [PR103312]

2024-05-23  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/103312
	* dependency.cc (gfc_dep_compare_expr): Handle component call
	expressions. Return -2 as default and return 0 if compared with
	a function expression that is from an interface body and has
	the same name.
	* expr.cc (gfc_reduce_init_expr): If the expression is a comp
	call do not attempt to reduce, defer to resolution and return
	false.
	* trans-types.cc (gfc_get_dtype_rank_type,
	gfc_get_nodesc_array_type): Fix whitespace.

gcc/testsuite/
	PR fortran/103312
	* gfortran.dg/pr103312.f90: New test.

diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc
index fb4d94de64131f80a1dba0625e53941cff08722a..bafe8cbc5bc3d7e86bbc262bac0d9cf5bcccb819 100644 (file)
--- a/gcc/fortran/dependency.cc
+++ b/gcc/fortran/dependency.cc
@@ -440,6 +440,38 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
        return mpz_sgn (e2->value.op.op2->value.integer);
     }
 
+
+  if (e1->expr_type == EXPR_COMPCALL)
+    {
+      /* This will have emerged from interface.cc(gfc_check_typebound_override)
+        via gfc_check_result_characteristics. It is possible that other
+        variants exist that are 'equal' but play it safe for now by setting
+        the relationship as 'indeterminate'.  */
+      if (e2->expr_type == EXPR_FUNCTION && e2->ref)
+       {
+         gfc_ref *ref = e2->ref;
+         gfc_symbol *s = NULL;
+
+         if (e1->value.compcall.tbp->u.specific)
+           s = e1->value.compcall.tbp->u.specific->n.sym;
+
+         /* Check if the proc ptr points to an interface declaration and the
+            names are the same; ie. the overriden proc. of an abstract type.
+            The checking of the arguments will already have been done.  */
+         for (; ref && s; ref = ref->next)
+           if (!ref->next && ref->type == REF_COMPONENT
+               && ref->u.c.component->attr.proc_pointer
+               && ref->u.c.component->ts.interface
+               && ref->u.c.component->ts.interface->attr.if_source
+                                                       == IFSRC_IFBODY
+               && !strcmp (s->name, ref->u.c.component->name))
+             return 0;
+       }
+
+      /* Assume as default that TKR checking is sufficient.  */
+     return -2;
+  }
+
   if (e1->expr_type != e2->expr_type)
     return -3;
 

diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index c883966646cb01035636087d03266d226a61b9f9..a162744c71934c12313ead1c4f04ceeec96d0a61 100644 (file)
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -3210,6 +3210,11 @@ gfc_reduce_init_expr (gfc_expr *expr)
 {
   bool t;
 
+  /* It is far too early to resolve a class compcall. Punt to resolution.  */
+  if (expr && expr->expr_type == EXPR_COMPCALL
+      && expr->symtree->n.sym->ts.type == BT_CLASS)
+    return false;
+
   gfc_init_expr_flag = true;
   t = gfc_resolve_expr (expr);
   if (t)

diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index 676014e9b98450a474965e103ea914ab2c74be30..8466c595e0650cce752b9eec92a02e8077a7f3fc 100644 (file)
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -1591,7 +1591,7 @@ gfc_get_dtype_rank_type (int rank, tree etype)
       size = size_in_bytes (etype);
       break;
     }
-      
+
   gcc_assert (size);
 
   STRIP_NOPS (size);
@@ -1740,7 +1740,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
        tmp = gfc_conv_mpz_to_tree (expr->value.integer,
                                    gfc_index_integer_kind);
       else
-       tmp = NULL_TREE;
+       tmp = NULL_TREE;
       GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
 
       expr = as->upper[n];

diff --git a/gcc/testsuite/gfortran.dg/pr103312.f90 b/gcc/testsuite/gfortran.dg/pr103312.f90
new file mode 100644 (file)
index 0000000..deacc70
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr103312.f90
@@ -0,0 +1,87 @@
+! { dg-do run }
+!
+! Test the fix for pr103312, in which the use of a component call in
+! initialization expressions, eg. character(this%size()), caused ICEs.
+!
+! Contributed by Arseny Solokha  <asolokha@gmx.com>
+!
+module example
+
+  type, abstract :: foo
+    integer :: i
+  contains
+    procedure(foo_size), deferred :: size
+    procedure(foo_func), deferred :: func
+  end type
+
+  interface
+    function foo_func (this) result (string)
+      import :: foo
+      class(foo) :: this
+      character(this%size()) :: string
+    end function
+    pure integer function foo_size (this)
+      import foo
+      class(foo), intent(in) :: this
+    end function
+  end interface
+
+end module
+
+module extension
+  use example
+  implicit none
+  type, extends(foo) :: bar
+  contains
+    procedure :: size
+    procedure :: func
+  end type
+
+contains
+    pure integer function size (this)
+      class(bar), intent(in) :: this
+      size = this%i
+    end function
+    function func (this) result (string)
+      class(bar) :: this
+      character(this%size()) :: string
+      string = repeat ("x", len (string))
+    end function
+
+end module
+
+module unextended
+  implicit none
+  type :: foobar
+    integer :: i
+  contains
+    procedure :: size
+    procedure :: func
+  end type
+
+contains
+    pure integer function size (this)
+      class(foobar), intent(in) :: this
+      size = this%i
+    end function
+    function func (this) result (string)
+      class(foobar) :: this
+      character(this%size()) :: string
+      character(:), allocatable :: chr
+      string = repeat ("y", len (string))
+      allocate (character(this%size()) :: chr)
+      if (len (string) .ne. len (chr)) stop 1
+    end function
+
+end module
+
+  use example
+  use extension
+  use unextended
+  type(bar) :: a
+  type(foobar) :: b
+  a%i = 5
+  if (a%func() .ne. 'xxxxx') stop 2
+  b%i = 7
+  if (b%func() .ne. 'yyyyyyy') stop 3
+end