diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 6 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 27 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/extends_type_of_2.f03 | 36 |
4 files changed, 60 insertions, 14 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5be47c6..b7f5afe 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2011-01-05 Janus Weil <janus@gcc.gnu.org> + + PR fortran/47180 + * trans-expr.c (gfc_trans_class_assign): For a polymorphic NULL pointer + assignment, set the _vptr component to the declared type. + 2011-01-05 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/46017 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 3e994aa..fa58376 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -6121,24 +6121,23 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) if (expr2->ts.type != BT_CLASS) { /* Insert an additional assignment which sets the '_vptr' field. */ + gfc_symbol *vtab; + gfc_symtree *st; + lhs = gfc_copy_expr (expr1); gfc_add_vptr_component (lhs); + if (expr2->ts.type == BT_DERIVED) - { - gfc_symbol *vtab; - gfc_symtree *st; - vtab = gfc_find_derived_vtab (expr2->ts.u.derived); - gcc_assert (vtab); - rhs = gfc_get_expr (); - rhs->expr_type = EXPR_VARIABLE; - gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st); - rhs->symtree = st; - rhs->ts = vtab->ts; - } + vtab = gfc_find_derived_vtab (expr2->ts.u.derived); else if (expr2->expr_type == EXPR_NULL) - rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); - else - gcc_unreachable (); + vtab = gfc_find_derived_vtab (expr1->ts.u.derived); + gcc_assert (vtab); + + rhs = gfc_get_expr (); + rhs->expr_type = EXPR_VARIABLE; + gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st); + rhs->symtree = st; + rhs->ts = vtab->ts; tmp = gfc_trans_pointer_assignment (lhs, rhs); gfc_add_expr_to_block (&block, tmp); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 1c3d417..ea5cac7 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2011-01-05 Janus Weil <janus@gcc.gnu.org> + + PR fortran/47180 + * gfortran.dg/extends_type_of_2.f03: New. + 2011-01-05 Ulrich Weigand <Ulrich.Weigand@de.ibm.com> * gcc.dg/stack-usage-1.c (SIZE): Provide proper value for __SPU__. diff --git a/gcc/testsuite/gfortran.dg/extends_type_of_2.f03 b/gcc/testsuite/gfortran.dg/extends_type_of_2.f03 new file mode 100644 index 0000000..f882cb1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/extends_type_of_2.f03 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! PR 47180: [OOP] EXTENDS_TYPE_OF returns the wrong result for disassociated polymorphic pointers +! +! Contributed by Tobias Burnus <burnus@gcc.gnu.org> + +implicit none + +type t1 + integer :: a +end type t1 + +type, extends(t1):: t11 + integer :: b +end type t11 + +type(t1) , target :: a1 +type(t11) , target :: a11 +class(t1) , pointer :: b1 +class(t11), pointer :: b11 + +b1 => NULL() +b11 => NULL() + +if (.not. extends_type_of(b1 , a1)) call abort() +if (.not. extends_type_of(b11, a1)) call abort() +if (.not. extends_type_of(b11,a11)) call abort() + +b1 => a1 +b11 => a11 + +if (.not. extends_type_of(b1 , a1)) call abort() +if (.not. extends_type_of(b11, a1)) call abort() +if (.not. extends_type_of(b11,a11)) call abort() + +end |