diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 13 | ||||
| -rw-r--r-- | gcc/fortran/class.c | 93 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 4 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 3 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 38 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 7 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/class_19.f03 | 2 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/class_allocate_6.f03 | 46 |
8 files changed, 179 insertions, 27 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 42e226d..cace0a3 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2010-11-05 Janus Weil <janus@gcc.gnu.org> + + PR fortran/45451 + PR fortran/46174 + * class.c (gfc_find_derived_vtab): Improved search for existing vtab. + Add component '$copy' to vtype symbol for polymorphic deep copying. + * expr.c (gfc_check_pointer_assign): Make sure the vtab is generated + during resolution stage. + * resolve.c (resolve_codes): Don't resolve code if namespace is already + resolved. + * trans-stmt.c (gfc_trans_allocate): Call '$copy' procedure for + polymorphic ALLOCATE statements with SOURCE. + 2010-11-03 Thomas Koenig <tkoenig@gcc.gnu.org> Paul Thomas <pault@gcc.gnu.org> diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 218247d..43907dc 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -39,9 +39,10 @@ along with GCC; see the file COPYING3. If not see * $hash: A hash value serving as a unique identifier for this type. * $size: The size in bytes of the derived type. * $extends: A pointer to the vtable entry of the parent derived type. - In addition to these fields, each vtable entry contains additional procedure - pointer components, which contain pointers to the procedures which are bound - to the type's "methods" (type-bound procedures). */ + * $def_init: A pointer to a default initialized variable of this type. + * $copy: A procedure pointer to a copying procedure. + After these follow procedure pointer components for the specific + type-bound procedures. */ #include "config.h" @@ -307,19 +308,14 @@ add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype) } -/* Find the symbol for a derived type's vtab. - A vtab has the following fields: - * $hash a hash value used to identify the derived type - * $size the size in bytes of the derived type - * $extends a pointer to the vtable of the parent derived type - After these follow procedure pointer components for the - specific type-bound procedures. */ +/* Find (or generate) the symbol for a derived type's vtab. */ gfc_symbol * gfc_find_derived_vtab (gfc_symbol *derived) { gfc_namespace *ns; gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; + gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; char name[2 * GFC_MAX_SYMBOL_LEN + 8]; /* Find the top-level namespace (MODULE or PROGRAM). */ @@ -334,7 +330,13 @@ gfc_find_derived_vtab (gfc_symbol *derived) if (ns) { sprintf (name, "vtab$%s", derived->name); - gfc_find_symbol (name, ns, 0, &vtab); + + /* Look for the vtab symbol in various namespaces. */ + gfc_find_symbol (name, gfc_current_ns, 0, &vtab); + if (vtab == NULL) + gfc_find_symbol (name, ns, 0, &vtab); + if (vtab == NULL) + gfc_find_symbol (name, derived->ns, 0, &vtab); if (vtab == NULL) { @@ -361,6 +363,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) NULL, &gfc_current_locus) == FAILURE) goto cleanup; vtype->attr.access = ACCESS_PUBLIC; + vtype->attr.vtype = 1; gfc_set_sym_referenced (vtype); /* Add component '$hash'. */ @@ -408,6 +411,14 @@ gfc_find_derived_vtab (gfc_symbol *derived) c->initializer = gfc_get_null_expr (NULL); } + if (derived->components == NULL && !derived->attr.zero_comp) + { + /* At this point an error must have occurred. + Prevent further errors on the vtype components. */ + found_sym = vtab; + goto have_vtype; + } + /* Add component $def_init. */ if (gfc_add_component (vtype, "$def_init", &c) == FAILURE) goto cleanup; @@ -416,7 +427,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) c->ts.type = BT_DERIVED; c->ts.u.derived = derived; if (derived->attr.abstract) - c->initializer = NULL; + c->initializer = gfc_get_null_expr (NULL); else { /* Construct default initialization variable. */ @@ -434,11 +445,61 @@ gfc_find_derived_vtab (gfc_symbol *derived) c->initializer = gfc_lval_expr_from_sym (def_init); } + /* Add component $copy. */ + if (gfc_add_component (vtype, "$copy", &c) == FAILURE) + goto cleanup; + c->attr.proc_pointer = 1; + c->attr.access = ACCESS_PRIVATE; + c->tb = XCNEW (gfc_typebound_proc); + c->tb->ppc = 1; + if (derived->attr.abstract) + c->initializer = gfc_get_null_expr (NULL); + else + { + /* Set up namespace. */ + gfc_namespace *sub_ns = gfc_get_namespace (ns, 0); + sub_ns->sibling = ns->contained; + ns->contained = sub_ns; + sub_ns->resolved = 1; + /* Set up procedure symbol. */ + sprintf (name, "copy$%s", derived->name); + gfc_get_symbol (name, sub_ns, ©); + sub_ns->proc_name = copy; + copy->attr.flavor = FL_PROCEDURE; + copy->attr.if_source = IFSRC_DECL; + gfc_set_sym_referenced (copy); + /* Set up formal arguments. */ + gfc_get_symbol ("src", sub_ns, &src); + src->ts.type = BT_DERIVED; + src->ts.u.derived = derived; + src->attr.flavor = FL_VARIABLE; + src->attr.dummy = 1; + gfc_set_sym_referenced (src); + copy->formal = gfc_get_formal_arglist (); + copy->formal->sym = src; + gfc_get_symbol ("dst", sub_ns, &dst); + dst->ts.type = BT_DERIVED; + dst->ts.u.derived = derived; + dst->attr.flavor = FL_VARIABLE; + dst->attr.dummy = 1; + gfc_set_sym_referenced (dst); + copy->formal->next = gfc_get_formal_arglist (); + copy->formal->next->sym = dst; + /* Set up code. */ + sub_ns->code = gfc_get_code (); + sub_ns->code->op = EXEC_ASSIGN; + sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst); + sub_ns->code->expr2 = gfc_lval_expr_from_sym (src); + /* Set initializer. */ + c->initializer = gfc_lval_expr_from_sym (copy); + c->ts.interface = copy; + } + /* Add procedure pointers for type-bound procedures. */ add_procs_to_declared_vtab (derived, vtype); - vtype->attr.vtype = 1; } +have_vtype: vtab->ts.u.derived = vtype; vtab->value = gfc_default_initializer (&vtab->ts); } @@ -456,6 +517,12 @@ cleanup: gfc_commit_symbol (vtype); if (def_init) gfc_commit_symbol (def_init); + if (copy) + gfc_commit_symbol (copy); + if (src) + gfc_commit_symbol (src); + if (dst) + gfc_commit_symbol (dst); } else gfc_undo_symbols (); diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 8dfbf73..2b98b35 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3457,6 +3457,10 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return FAILURE; } + if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED) + /* Make sure the vtab is present. */ + gfc_find_derived_vtab (rvalue->ts.u.derived); + /* Check rank remapping. */ if (rank_remap) { diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 6e71e13..7429ff2 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -13331,6 +13331,9 @@ resolve_codes (gfc_namespace *ns) gfc_namespace *n; bitmap_obstack old_obstack; + if (ns->resolved == 1) + return; + for (n = ns->contained; n; n = n->sibling) resolve_codes (n); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index f065adb..d075ac8 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -4487,21 +4487,33 @@ gfc_trans_allocate (gfc_code * code) /* Initialization via SOURCE block (or static default initializer). */ gfc_expr *rhs = gfc_copy_expr (code->expr3); - if (al->expr->ts.type == BT_CLASS && rhs->expr_type == EXPR_VARIABLE - && rhs->ts.type != BT_CLASS) - tmp = gfc_trans_assignment (expr, rhs, false, false); - else if (al->expr->ts.type == BT_CLASS) + if (al->expr->ts.type == BT_CLASS) { - /* TODO: One needs to do a deep-copy for BT_CLASS; cf. PR 46174. */ - gfc_se dst,src; + gfc_se call; + gfc_actual_arglist *actual; + gfc_expr *ppc; + gfc_init_se (&call, NULL); + /* Do a polymorphic deep copy. */ + actual = gfc_get_actual_arglist (); + actual->expr = gfc_copy_expr (rhs); if (rhs->ts.type == BT_CLASS) - gfc_add_component_ref (rhs, "$data"); - gfc_init_se (&dst, NULL); - gfc_init_se (&src, NULL); - gfc_conv_expr (&dst, expr); - gfc_conv_expr (&src, rhs); - gfc_add_block_to_block (&block, &src.pre); - tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz); + gfc_add_component_ref (actual->expr, "$data"); + actual->next = gfc_get_actual_arglist (); + actual->next->expr = gfc_copy_expr (al->expr); + gfc_add_component_ref (actual->next->expr, "$data"); + if (rhs->ts.type == BT_CLASS) + { + ppc = gfc_copy_expr (rhs); + gfc_add_component_ref (ppc, "$vptr"); + } + else + ppc = gfc_lval_expr_from_sym (gfc_find_derived_vtab (rhs->ts.u.derived)); + gfc_add_component_ref (ppc, "$copy"); + gfc_conv_procedure_call (&call, ppc->symtree->n.sym, actual, + ppc, NULL); + gfc_add_expr_to_block (&call.pre, call.expr); + gfc_add_block_to_block (&call.pre, &call.post); + tmp = gfc_finish_block (&call.pre); } else tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index c7189a9..359bc49 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2010-11-05 Janus Weil <janus@gcc.gnu.org> + + PR fortran/45451 + PR fortran/46174 + * gfortran.dg/class_19.f03: Modified. + * gfortran.dg/class_allocate_6.f03: New. + 2010-11-05 H.J. Lu <hongjiu.lu@intel.com> * gcc.target/i386/avx-vzeroupper-19.c: New. diff --git a/gcc/testsuite/gfortran.dg/class_19.f03 b/gcc/testsuite/gfortran.dg/class_19.f03 index 78e5652..27ee7b4 100644 --- a/gcc/testsuite/gfortran.dg/class_19.f03 +++ b/gcc/testsuite/gfortran.dg/class_19.f03 @@ -39,7 +39,7 @@ program main end program main -! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 11 "original" } } ! { dg-final { cleanup-tree-dump "original" } } ! { dg-final { cleanup-modules "foo_mod" } } diff --git a/gcc/testsuite/gfortran.dg/class_allocate_6.f03 b/gcc/testsuite/gfortran.dg/class_allocate_6.f03 new file mode 100644 index 0000000..8b96d1d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_allocate_6.f03 @@ -0,0 +1,46 @@ +! { dg-do run } +! +! PR 46174: [OOP] ALLOCATE with SOURCE: Deep copy missing +! +! Contributed by Tobias Burnus <burnus@gcc.gnu.org> + +implicit none +type t +end type t + +type, extends(t) :: t2 + integer, allocatable :: a(:) +end type t2 + +class(t), allocatable :: x, y +integer :: i + +allocate(t2 :: x) +select type(x) + type is (t2) + allocate(x%a(10)) + x%a = [ (i, i = 1,10) ] + print '(*(i3))', x%a + class default + call abort() +end select + +allocate(y, source=x) + +select type(x) + type is (t2) + x%a = [ (i, i = 11,20) ] + print '(*(i3))', x%a + class default + call abort() +end select + +select type(y) + type is (t2) + print '(*(i3))', y%a + if (any (y%a /= [ (i, i = 1,10) ])) call abort() + class default + call abort() +end select + +end |