Hi All, The original error has changed to a segfault in run time. Nevertheless, the fix posted a while back on the PR compiles, runs and regtests on FC42/x86_64.
The first chunk gets rid of the segfault since it passes a class container to 'f', rather than the array descriptor. The second chunk resets the temporary descriptor lbounds to one, adjusts the ubounds accordingly and sets the offset. As remarked in comment 8, the version with an allocatable component 'a' is thoroughly broken. This is now PR124503. The other chunks are trivial conversions of NULL to NULL_TREE. OK for mainline and backporting? Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 104a9584686..c02b258e844 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1317,13 +1317,12 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
stmtblock_t block;
bool full_array = false;
- /* Class transformational function results are the data field of a class
- temporary and so the class expression can be obtained directly. */
- if (e->expr_type == EXPR_FUNCTION
- && e->value.function.isym
- && e->value.function.isym->transformational
+ /* If this is the data field of a class temporary, the class expression
+ can be obtained and returned directly. */
+ if (e->expr_type != EXPR_VARIABLE
&& TREE_CODE (parmse->expr) == COMPONENT_REF
- && !GFC_CLASS_TYPE_P (TREE_TYPE (parmse->expr)))
+ && !GFC_CLASS_TYPE_P (TREE_TYPE (parmse->expr))
+ && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (parmse->expr, 0))))
{
parmse->expr = TREE_OPERAND (parmse->expr, 0);
if (!VAR_P (parmse->expr))
@@ -7789,6 +7788,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_init_block (&class_se.pre);
gfc_init_block (&class_se.post);
+ if (e->expr_type != EXPR_VARIABLE)
+ {
+ int n;
+ /* Set the bounds and offset correctly. */
+ for (n = 0; n < e->rank; n++)
+ gfc_conv_shift_descriptor_lbound (&class_se.pre,
+ class_se.expr,
+ n, gfc_index_one_node);
+ }
+
/* The conversion does not repackage the reference to a class
array - _data descriptor. */
gfc_conv_class_to_class (&class_se, e, fsym->ts, false,
@@ -12179,8 +12188,13 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
gfc_symbol *sym = expr1->symtree->n.sym;
bool finalizable = gfc_may_be_finalized (expr1->ts);
+ /* If the symbol is host associated and has not been referenced in its name
+ space, it might be lacking a backend_decl and vtable. */
+ if (sym->backend_decl == NULL_TREE)
+ return NULL_TREE;
+
if (arrayfunc_assign_needs_temporary (expr1, expr2))
- return NULL;
+ return NULL_TREE;
/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
functions. */
@@ -12190,7 +12204,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
|| (comp && comp->attr.dimension)
|| (!comp && gfc_return_by_reference (expr2->value.function.esym)
&& expr2->value.function.esym->result->attr.dimension)))
- return NULL;
+ return NULL_TREE;
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
diff --git a/gcc/testsuite/gfortran.dg/pr105168.f90 b/gcc/testsuite/gfortran.dg/pr105168.f90
new file mode 100644
index 00000000000..03daf2f3e0a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr105168.f90
@@ -0,0 +1,38 @@
+! { dg-do run }
+! Test fix for PR105168, in which nterface mapping was failing with CLASS 'x'
+! and parentheses around the actual argument.
+!
+! Contributed by Gerhard Steinmetz <[email protected]>
+!
+module m
+ type t
+ integer :: a
+ contains
+ final :: final_t
+ end type
+ integer :: cntr = 0
+contains
+ function f(x, factor) result(z)
+ class(t) :: x(:) ! Worked, with or without parentheses if s/CLASS/TYPE/
+ type(t) :: z(2)
+ integer :: factor
+ z = x ! Seg fault here
+ z%a = factor * z%a
+ end
+ impure elemental subroutine final_t (arg)
+ type (t), intent(in) :: arg
+ cntr = cntr + 1
+ end subroutine
+end module
+program p
+ use m
+ class(t), allocatable :: y(:), z(:)
+ y = [t(2),t(4)]
+ allocate (t :: z(2))
+ z = f((y), 1) ! Failed even with parentheses removed
+ if (any(z%a /= [2,4])) stop 1
+ z = f(y, 2) ! Failed but now OK
+ if (any (z%a /= [4,8])) stop 2
+ deallocate (y, z)
+ if (cntr /= 16) stop 3 ! 6 for each assignment and 4 for deallocation
+end
