Hello,
this patch, extracted with some modifications from PR50981 comment #28
[http://gcc.gnu.org/bugzilla/show_bug.cgi?id=50981#c28],
(which has accumulated a lot of things) fixes an ICE noticed in several
PRs with an error like:
internal compiler error: in gfc_conv_descriptor_data_get,
at fortran/trans-array.c:147
internal compiler error: in gfc_conv_descriptor_offset, at
fortran/trans-array.c:210
the problem is a missing "_data" reference (to escape the class
container) when trying to access a subobject of a class object.
The solution proposed is to replace the call to
gfc_add_component_ref(expr, "_data") with a call to a new, more general,
function gfc_fix_class_refs which takes care of adding the "_data"
component in all references (not only the last one) where it is missing.
Thus, it works
- in the scalar case: class%array_comp(1), class%scalar_comp
- with multiple level of components: class%comp%subclass%sub_comp
- in the array case (but this was working before): class%array_comp(:)
- in any mix of the above cases.
I have chosen to make it a separate function instead of fixing
gfc_add_component_ref, so that it can be reused later (maybe...) even if
we don't want to add a "_data", or "_vptr" or ... component.
W.R.T. the code itself, I think it is rather straightforward. There is
an odd thing to prevent a regression in class_41.f03. See the big
comment in class_data_ref_missing.
Regression tested on x86_64-unknown-freebsd9.0. OK for trunk?
Mikael
2012-02-02 Mikael Morin <mik...@gcc.gnu.org>
PR fortran/41587
PR fortran/46356
PR fortran/51754
PR fortran/50981
* class.c (insert_component_ref, class_data_ref_missing,
gfc_fix_class_refs): New functions.
* gfortran.h (gfc_fix_class_refs): New prototype.
* trans-expr.c (gfc_conv_expr): Remove special case handling and call
gfc_fix_class_refs instead.
diff --git a/class.c b/class.c
index 52c5a61..24e06d2 100644
--- a/class.c
+++ b/class.c
@@ -52,6 +52,129 @@ along with GCC; see the file COPYING3. If not see
#include "constructor.h"
+/* Inserts a derived type component reference in a data reference chain.
+ TS: base type of the ref chain so far, in which we will pick the component
+ REF: the address of the GFC_REF pointer to update
+ NAME: name of the component to insert
+ Note that component insertion makes sense only if we are at the end of
+ the chain (*REF == NULL) or if we are adding a missing "_data" component
+ to access the actual contents of a class object. */
+
+static void
+insert_component_ref (gfc_typespec *ts, gfc_ref **ref, const char * const name)
+{
+ gfc_symbol *type_sym;
+ gfc_ref *new_ref;
+
+ gcc_assert (ts->type == BT_DERIVED || ts->type == BT_CLASS);
+ type_sym = ts->u.derived;
+
+ new_ref = gfc_get_ref ();
+ new_ref->type = REF_COMPONENT;
+ new_ref->next = *ref;
+ new_ref->u.c.sym = type_sym;
+ new_ref->u.c.component = gfc_find_component (type_sym, name, true, true);
+ gcc_assert (new_ref->u.c.component);
+
+ if (new_ref->next)
+ {
+ gfc_ref *next = NULL;
+
+ /* We need to update the base type in the trailing reference chain to
+ that of the new component. */
+
+ gcc_assert (strcmp (name, "_data") == 0);
+
+ if (new_ref->next->type == REF_COMPONENT)
+ next = new_ref->next;
+ else if (new_ref->next->type == REF_ARRAY
+ && new_ref->next->next
+ && new_ref->next->next->type == REF_COMPONENT)
+ next = new_ref->next->next;
+
+ if (next != NULL)
+ {
+ gcc_assert (new_ref->u.c.component->ts.type == BT_CLASS
+ || new_ref->u.c.component->ts.type == BT_DERIVED);
+ next->u.c.sym = new_ref->u.c.component->ts.u.derived;
+ }
+ }
+
+ *ref = new_ref;
+}
+
+
+/* Tells whether we need to add a "_data" reference to access REF subobject
+ from an object of type TS. If FIRST_REF_IN_CHAIN is set, then the base
+ object accessed by REF is a variable; in other words it is a full object,
+ not a subobject. */
+
+static bool
+class_data_ref_missing (gfc_typespec *ts, gfc_ref *ref, bool
first_ref_in_chain)
+{
+ /* Only class containers may need the "_data" reference. */
+ if (ts->type != BT_CLASS)
+ return false;
+
+ /* Accessing a class container with an array reference is certainly wrong.
*/
+ if (ref->type != REF_COMPONENT)
+ return true;
+
+ /* Accessing the class container's fields is fine. */
+ if (ref->u.c.component->name[0] == '_')
+ return false;
+
+ /* At this point we have a class container with a non class container's field
+ component reference. We don't want to add the "_data" component if we are
+ at the first reference and the symbol's type is an extended derived type.
+ In that case, conv_parent_component_references will do the right thing so
+ it is not absolutely necessary. Omitting it prevents a regression (see
+ class_41.f03) in the interface mapping mechanism. When evaluating string
+ lengths depending on dummy arguments, we create a fake symbol with a type
+ equal to that of the dummy type. However, because of type extension,
+ the backend type (corresponding to the actual argument) can have a
+ different (extended) type. Adding the "_data" component explicitly, using
+ the base type, confuses the gfc_conv_component_ref code which deals with
+ the extended type. */
+ if (first_ref_in_chain && ts->u.derived->attr.extension)
+ return false;
+
+ /* We have a class container with a non class container's field component
+ reference that doesn't fall into the above. */
+ return true;
+}
+
+
+/* Browse through a data reference chain and add the missing "_data" references
+ when a subobject of a class object is accessed without it.
+ Note that it doesn't add the "_data" reference when the class container
+ is the last element in the reference chain. */
+
+void
+gfc_fix_class_refs (gfc_expr *e)
+{
+ gfc_typespec *ts;
+ gfc_ref **ref;
+
+ if ((e->expr_type != EXPR_VARIABLE
+ && e->expr_type != EXPR_FUNCTION)
+ || (e->expr_type == EXPR_FUNCTION
+ && e->value.function.isym != NULL))
+ return;
+
+ ts = &e->symtree->n.sym->ts;
+
+ for (ref = &e->ref; *ref != NULL; ref = &(*ref)->next)
+ {
+ if (class_data_ref_missing (ts, *ref, ref == &e->ref))
+ insert_component_ref (ts, ref, "_data");
+
+ if ((*ref)->type == REF_COMPONENT)
+ ts = &(*ref)->u.c.component->ts;
+ }
+}
+
+
/* Insert a reference to the component of the given name.
Only to be used with CLASS containers and vtables. */
diff --git a/gfortran.h b/gfortran.h
index 23c16ba..6989eb1 100644
--- a/gfortran.h
+++ b/gfortran.h
@@ -2919,6 +2919,7 @@ gfc_try gfc_calculate_transfer_sizes (gfc_expr*,
gfc_expr*, gfc_expr*,
size_t*, size_t*, size_t*);
/* class.c */
+void gfc_fix_class_refs (gfc_expr *e);
void gfc_add_component_ref (gfc_expr *, const char *);
void gfc_add_class_array_ref (gfc_expr *);
#define gfc_add_data_component(e) gfc_add_component_ref(e,"_data")
diff --git a/trans-expr.c b/trans-expr.c
index 7543149..ea6a993 100644
--- a/trans-expr.c
+++ b/trans-expr.c
@@ -5486,10 +5486,7 @@ gfc_conv_expr (gfc_se * se, gfc_expr * expr)
}
}
- /* TODO: make this work for general class array expressions. */
- if (expr->ts.type == BT_CLASS
- && expr->ref && expr->ref->type == REF_ARRAY)
- gfc_add_component_ref (expr, "_data");
+ gfc_fix_class_refs (expr);
switch (expr->expr_type)
{
2012-02-02 Mikael Morin <mik...@gcc.gnu.org>
PR fortran/41587
* gfortran.dg/class_array_10.f03: New test.
PR fortran/46356
* gfortran.dg/class_array_11.f03: New test.
PR fortran/51754
* gfortran.dg/class_array_12.f03: New test.
! { dg-do compile}
!
! PR fortran/41587
! This program was leading to an ICE related to class allocatable arrays
!
! Contributed by Dominique D'Humieres <domi...@lps.ens.fr>
type t0
integer :: j = 42
end type t0
type t
integer :: i
class(t0), allocatable :: foo(:)
end type t
type(t) :: k
allocate(t0 :: k%foo(3))
print *, k%foo%j
end
! { dg-do compile }
!
! PR fortran/46356
! This program was leading to an ICE related to class arrays
!
! Original testcase by Ian Harvey <ian_har...@bigpond.com>
! Reduced by Janus Weil <ja...@gcc.gnu.org>
IMPLICIT NONE
TYPE :: ParentVector
INTEGER :: a
END TYPE ParentVector
CONTAINS
SUBROUTINE vector_operation(pvec)
CLASS(ParentVector), INTENT(INOUT) :: pvec(:)
print *,pvec(1)%a
END SUBROUTINE
END
! { dg-do compile }
!
! PR fortran/51754
! This program was leading to an ICE related to class arrays
!
! Contributed by Andrew Benson <aben...@caltech.edu>
module test
private
type :: componentB
end type componentB
type :: treeNode
class(componentB), allocatable, dimension(:) :: componentB
end type treeNode
contains
function BGet(self)
implicit none
class(componentB), pointer :: BGet
class(treeNode), target, intent(in) :: self
select type (self)
class is (treeNode)
BGet => self%componentB(1)
end select
return
end function BGet
end module test
! { dg-final { cleanup-modules "test" } }
