From f8dde8af6f4bf8d16fcb12544caef0aad3da56f2 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Sat, 15 May 2010 15:52:33 +0200 Subject: [PATCH] re PR fortran/43207 ([OOP] invalid (pointer) assignment to and from abstract non-polymorphic expressions) 2010-05-15 Janus Weil PR fortran/43207 PR fortran/43969 * gfortran.h (gfc_class_null_initializer): New prototype. * expr.c (gfc_class_null_initializer): New function to build a NULL initializer for CLASS pointers. * symbol.c (gfc_build_class_symbol): Modify internal naming of class containers. Remove default NULL initialization of $data component. * trans.c (gfc_allocate_array_with_status): Fix wording of an error message. * trans-expr.c (gfc_conv_initializer,gfc_trans_subcomponent_assign): Use new function 'gfc_class_null_initializer'. * trans-intrinsic.c (gfc_conv_allocated): Handle allocatable scalar class variables. 2010-05-15 Janus Weil PR fortran/43207 PR fortran/43969 * gfortran.dg/class_18.f03: New. * gfortran.dg/class_19.f03: New. From-SVN: r159431 --- gcc/fortran/ChangeLog | 16 ++++++++++ gcc/fortran/expr.c | 26 ++++++++++++++++ gcc/fortran/gfortran.h | 1 + gcc/fortran/symbol.c | 12 ++++---- gcc/fortran/trans-expr.c | 7 +++-- gcc/fortran/trans-intrinsic.c | 2 ++ gcc/fortran/trans.c | 6 ++-- gcc/testsuite/ChangeLog | 7 +++++ gcc/testsuite/gfortran.dg/class_18.f03 | 18 +++++++++++ gcc/testsuite/gfortran.dg/class_19.f03 | 41 ++++++++++++++++++++++++++ 10 files changed, 125 insertions(+), 11 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/class_18.f03 create mode 100644 gcc/testsuite/gfortran.dg/class_19.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a95d16d6dd2..dd6d23fcd7d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,19 @@ +2010-05-15 Janus Weil + + PR fortran/43207 + PR fortran/43969 + * gfortran.h (gfc_class_null_initializer): New prototype. + * expr.c (gfc_class_null_initializer): New function to build a NULL + initializer for CLASS pointers. + * symbol.c (gfc_build_class_symbol): Modify internal naming of class + containers. Remove default NULL initialization of $data component. + * trans.c (gfc_allocate_array_with_status): Fix wording of an error + message. + * trans-expr.c (gfc_conv_initializer,gfc_trans_subcomponent_assign): + Use new function 'gfc_class_null_initializer'. + * trans-intrinsic.c (gfc_conv_allocated): Handle allocatable scalar + class variables. + 2010-05-14 Steven G. Kargl PR fortran/44135 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 8230b46d6a2..382d1fe6452 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3628,6 +3628,32 @@ gfc_default_initializer (gfc_typespec *ts) } +/* Build a NULL initializer for CLASS pointers, + initializing the $data and $vptr components to zero. */ + +gfc_expr * +gfc_class_null_initializer (gfc_typespec *ts) +{ + gfc_expr *init; + gfc_component *comp; + + init = gfc_get_structure_constructor_expr (ts->type, ts->kind, + &ts->u.derived->declared_at); + init->ts = *ts; + + for (comp = ts->u.derived->components; comp; comp = comp->next) + { + gfc_constructor *ctor = gfc_constructor_get(); + ctor->expr = gfc_get_expr (); + ctor->expr->expr_type = EXPR_NULL; + ctor->expr->ts = comp->ts; + gfc_constructor_append (&init->value.constructor, ctor); + } + + return init; +} + + /* Given a symbol, create an expression node with that symbol as a variable. If the symbol is array valued, setup a reference of the whole array. */ diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 91c8b80ba64..96acaa4574e 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2630,6 +2630,7 @@ gfc_try gfc_check_pointer_assign (gfc_expr *, gfc_expr *); gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *); gfc_expr *gfc_default_initializer (gfc_typespec *); +gfc_expr *gfc_class_null_initializer (gfc_typespec *); gfc_expr *gfc_get_variable_expr (gfc_symtree *); gfc_array_spec *gfc_get_full_arrayspec_from_expr (gfc_expr *expr); diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 8403578b81e..ceb45bfa6ec 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4717,15 +4717,15 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, /* Determine the name of the encapsulating type. */ if ((*as) && (*as)->rank && attr->allocatable) - sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank); + sprintf (name, "class$%s_%d_a", ts->u.derived->name, (*as)->rank); else if ((*as) && (*as)->rank) - sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank); + sprintf (name, "class$%s_%d", ts->u.derived->name, (*as)->rank); else if (attr->pointer) - sprintf (name, ".class.%s.p", ts->u.derived->name); + sprintf (name, "class$%s_p", ts->u.derived->name); else if (attr->allocatable) - sprintf (name, ".class.%s.a", ts->u.derived->name); + sprintf (name, "class$%s_a", ts->u.derived->name); else - sprintf (name, ".class.%s", ts->u.derived->name); + sprintf (name, "class$%s", ts->u.derived->name); gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass); if (fclass == NULL) @@ -4759,7 +4759,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->attr.codimension = attr->codimension; c->attr.abstract = ts->u.derived->attr.abstract; c->as = (*as); - c->initializer = gfc_get_null_expr (NULL); + c->initializer = NULL; /* Add component '$vptr'. */ if (gfc_add_component (fclass, "$vptr", &c) == FAILURE) diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 47883e258bb..4d48c05b7aa 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -3894,7 +3894,10 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type, case BT_DERIVED: case BT_CLASS: gfc_init_se (&se, NULL); - gfc_conv_structure (&se, expr, 1); + if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL) + gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1); + else + gfc_conv_structure (&se, expr, 1); return se.expr; case BT_CHARACTER: @@ -4202,7 +4205,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) { /* NULL initialization for CLASS components. */ tmp = gfc_trans_structure_assign (dest, - gfc_default_initializer (&cm->ts)); + gfc_class_null_initializer (&cm->ts)); gfc_add_expr_to_block (&block, tmp); } else if (cm->attr.dimension) diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 1ffe2842ce3..257b6842d28 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -4529,6 +4529,8 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr) { /* Allocatable scalar. */ arg1se.want_pointer = 1; + if (arg1->expr->ts.type == BT_CLASS) + gfc_add_component_ref (arg1->expr, "$data"); gfc_conv_expr (&arg1se, arg1->expr); tmp = arg1se.expr; } diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 8acccf85027..3a25bcc02d9 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -704,7 +704,7 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status) return mem; } else - runtime_error ("Attempting to allocate already allocated array"); + runtime_error ("Attempting to allocate already allocated variable"); } } @@ -743,13 +743,13 @@ gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size, error = gfc_trans_runtime_error (true, &expr->where, "Attempting to allocate already" - " allocated array '%s'", + " allocated variable '%s'", varname); } else error = gfc_trans_runtime_error (true, NULL, "Attempting to allocate already allocated" - "array"); + "variable"); if (status != NULL_TREE && !integer_zerop (status)) { diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a8131214b18..1e3d9c7b5cb 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2010-05-15 Janus Weil + + PR fortran/43207 + PR fortran/43969 + * gfortran.dg/class_18.f03: New. + * gfortran.dg/class_19.f03: New. + 2010-05-14 Jakub Jelinek PR debug/44112 diff --git a/gcc/testsuite/gfortran.dg/class_18.f03 b/gcc/testsuite/gfortran.dg/class_18.f03 new file mode 100644 index 00000000000..576f931f969 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_18.f03 @@ -0,0 +1,18 @@ +! { dg-do run } +! +! PR 43207: [OOP] ICE for class pointer => null() initialization +! +! Original test case by Tobias Burnus +! Modified by Janus Weil + + implicit none + type :: parent + end type + type(parent), target :: t + class(parent), pointer :: cp => null() + + if (associated(cp)) call abort() + cp => t + if (.not. associated(cp)) call abort() + +end diff --git a/gcc/testsuite/gfortran.dg/class_19.f03 b/gcc/testsuite/gfortran.dg/class_19.f03 new file mode 100644 index 00000000000..ffc3de3b1e4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_19.f03 @@ -0,0 +1,41 @@ +! { dg-do run } +! +! PR 43969: [OOP] ALLOCATED() with polymorphic variables +! +! Contributed by Salvatore Filippone + + +module foo_mod + type foo_inner + integer, allocatable :: v(:) + end type foo_inner + type foo_outer + class(foo_inner), allocatable :: int + end type foo_outer +contains +subroutine foo_checkit() + implicit none + type(foo_outer) :: try + type(foo_outer),allocatable :: try2 + class(foo_outer), allocatable :: try3 + + if (allocated(try%int)) call abort() + allocate(foo_outer :: try3) + if (allocated(try3%int)) call abort() + allocate(try2) + if (allocated(try2%int)) call abort() + +end subroutine foo_checkit +end module foo_mod + + +program main + + use foo_mod + implicit none + + call foo_checkit() + +end program main + +! { dg-final { cleanup-modules "foo_mod" } } -- 2.30.2