https://gcc.gnu.org/g:1b22831d3c74a1b3e72dab840e2818e495ecd567
commit r13-8907-g1b22831d3c74a1b3e72dab840e2818e495ecd567
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Thu May 23 07:59:46 2024 +0100
Fortran: Fix ICEs due to comp calls in initialization exprs [PR103312]
2024-05-23 Paul Thomas <pa...@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.
(cherry picked from commit 2ce90517ed75c4af9fc0616f2670cf6dfcfa8a91)
Diff:
---
gcc/fortran/dependency.cc | 32 +++++++++++++
gcc/fortran/expr.cc | 5 ++
gcc/fortran/trans-types.cc | 4 +-
gcc/testsuite/gfortran.dg/pr103312.f90 | 87 ++++++++++++++++++++++++++++++++++
4 files changed, 126 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/dependency.cc b/gcc/fortran/dependency.cc
index 9117825ee6e8..f928099e9e2f 100644
--- 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 4a9b29c7e9d5..90d2daa08642 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -3188,6 +3188,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 b2a3000da1fe..0c59ab3f5b57 100644
--- 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);
@@ -1736,7 +1736,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
index 000000000000..deacc70bf5df
--- /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 <asolo...@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
