procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/45451 ([OOP] Inconsistent status of ALLOCATABLE components inside CLASS variables.)

Browse source 
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-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.

From-SVN: r166368
This commit is contained in:
Janus Weil 2010-11-05 19:14:52 +01:00
parent 458ebeba0f
commit 611c64f069
8 changed files with 179 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
gcc/fortran/ChangeLog
View file

@ -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>

93
gcc/fortran/class.c
View file

@ -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, &copy);
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 ();

4
gcc/fortran/expr.c
View file

@ -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)
{

3
gcc/fortran/resolve.c
View file

@ -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);

38
gcc/fortran/trans-stmt.c
View file

@ -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),

7
gcc/testsuite/ChangeLog
View file

@ -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.

2
gcc/testsuite/gfortran.dg/class_19.f03
View file

@ -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" } }

46
gcc/testsuite/gfortran.dg/class_allocate_6.f03 Normal file
View file

@ -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