OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/51529 ([OOP] gfortran.dg/class_to_type_1.f03 is miscompiled: Uninitialized variable used) 

2012-01-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/51529
	* trans-array.c (gfc_array_allocate): Null allocated memory of
	newly allocted class arrays.

	PR fortran/46262
	PR fortran/46328
	PR fortran/51052
	* interface.c(build_compcall_for_operator): Add a type to the
	expression.
	* trans-expr.c (conv_base_obj_fcn_val): New function.
	(gfc_conv_procedure_call): Use base_expr to detect non-variable
	base objects and, ensuring that there is a temporary variable,
	build up the typebound call using conv_base_obj_fcn_val.
	(gfc_trans_class_assign): Pick out class procedure pointer
	assignments and do the assignment with no further prcessing.
	(gfc_trans_class_array_init_assign, gfc_trans_class_init_assign
	gfc_trans_class_assign): Move to top of file.
	* gfortran.h : Add 'base_expr' field to gfc_expr.
	* resolve.c (get_declared_from_expr): Add 'types' argument to
	switch checking of derived types on or off.
	(resolve_typebound_generic_call): Set the new argument.
	(resolve_typebound_function, resolve_typebound_subroutine):
	Set 'types' argument for get_declared_from_expr appropriately.
	Identify base expression, if not a variable, in the argument
	list of class valued calls. Assign it to the 'base_expr' field
	of the final expression. Strip away all references after the
	last class reference.


2012-01-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/46262
	PR fortran/46328
	PR fortran/51052
	* gfortran.dg/typebound_operator_7.f03: New.
	* gfortran.dg/typebound_operator_8.f03: New.

From-SVN: r182796
This commit is contained in:
Paul Thomas 2012-01-02 12:46:08 +00:00
parent 9ecd3a64a9
commit 94fae14bf8
10 changed files with 956 additions and 170 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
gcc/fortran/ChangeLog
View File

@ -1,3 +1,33 @@
2012-01-02 Paul Thomas <pault@gcc.gnu.org>
PR fortran/51529
* trans-array.c (gfc_array_allocate): Null allocated memory of
newly allocted class arrays.
PR fortran/46262
PR fortran/46328
PR fortran/51052
* interface.c(build_compcall_for_operator): Add a type to the
expression.
* trans-expr.c (conv_base_obj_fcn_val): New function.
(gfc_conv_procedure_call): Use base_expr to detect non-variable
base objects and, ensuring that there is a temporary variable,
build up the typebound call using conv_base_obj_fcn_val.
(gfc_trans_class_assign): Pick out class procedure pointer
assignments and do the assignment with no further prcessing.
(gfc_trans_class_array_init_assign, gfc_trans_class_init_assign
gfc_trans_class_assign): Move to top of file.
* gfortran.h : Add 'base_expr' field to gfc_expr.
* resolve.c (get_declared_from_expr): Add 'types' argument to
switch checking of derived types on or off.
(resolve_typebound_generic_call): Set the new argument.
(resolve_typebound_function, resolve_typebound_subroutine):
Set 'types' argument for get_declared_from_expr appropriately.
Identify base expression, if not a variable, in the argument
list of class valued calls. Assign it to the 'base_expr' field
of the final expression. Strip away all references after the
last class reference.
2012-01-02 Tobias Burnus <burnus@net-b.de>
PR fortran/51682

1
gcc/fortran/dump-parse-tree.c
View File

@ -2330,3 +2330,4 @@ gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
dumpfile = file;
show_namespace (ns);
}

6
gcc/fortran/gfortran.h
View File

@ -1,6 +1,6 @@
/* gfortran header file
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
2009, 2010, 2011
2009, 2010, 2011, 2012
Free Software Foundation, Inc.
Contributed by Andy Vaught
@ -1697,6 +1697,10 @@ typedef struct gfc_expr
locus where;
/* Used to store the base expression in component calls, when the expression
is not a variable. */
gfc_expr *base_expr;
/* is_boz is true if the integer is regarded as BOZ bitpatten and is_snan
denotes a signalling not-a-number. */
unsigned int is_boz : 1, is_snan : 1;

10
gcc/fortran/interface.c
View File

@ -1,6 +1,6 @@
/* Deal with interfaces.
Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009,
2010
2010, 2011, 2012
Free Software Foundation, Inc.
Contributed by Andy Vaught
@ -3256,6 +3256,14 @@ build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
e->value.compcall.base_object = base;
e->value.compcall.ignore_pass = 1;
e->value.compcall.assign = 0;
if (e->ts.type == BT_UNKNOWN
&& target->function)
{
if (target->is_generic)
e->ts = target->u.generic->specific->u.specific->n.sym->ts;
else
e->ts = target->u.specific->n.sym->ts;
}
}

84
gcc/fortran/resolve.c
View File

@ -1,6 +1,6 @@
/* Perform type resolution on the various structures.
Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
2010, 2011
2010, 2011, 2012
Free Software Foundation, Inc.
Contributed by Andy Vaught
@ -5620,10 +5620,11 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
/* Get the ultimate declared type from an expression. In addition,
return the last class/derived type reference and the copy of the
reference list. */
reference list. If check_types is set true, derived types are
identified as well as class references. */
static gfc_symbol*
get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
gfc_expr *e)
gfc_expr *e, bool check_types)
{
gfc_symbol *declared;
gfc_ref *ref;
@ -5639,8 +5640,9 @@ get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
if (ref->type != REF_COMPONENT)
continue;
if (ref->u.c.component->ts.type == BT_CLASS
|| ref->u.c.component->ts.type == BT_DERIVED)
if ((ref->u.c.component->ts.type == BT_CLASS
|| (check_types && ref->u.c.component->ts.type == BT_DERIVED))
&& ref->u.c.component->attr.flavor != FL_PROCEDURE)
{
declared = ref->u.c.component->ts.u.derived;
if (class_ref)
@ -5735,7 +5737,7 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name)
success:
/* Make sure that we have the right specific instance for the name. */
derived = get_declared_from_expr (NULL, NULL, e);
derived = get_declared_from_expr (NULL, NULL, e, true);
st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
if (st)
@ -5852,7 +5854,7 @@ resolve_compcall (gfc_expr* e, const char **name)
/* Resolve a typebound function, or 'method'. First separate all
the non-CLASS references by calling resolve_compcall directly. */
static gfc_try
gfc_try
resolve_typebound_function (gfc_expr* e)
{
gfc_symbol *declared;
@ -5872,6 +5874,21 @@ resolve_typebound_function (gfc_expr* e)
overridable = !e->value.compcall.tbp->non_overridable;
if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
{
/* If the base_object is not a variable, the corresponding actual
argument expression must be stored in e->base_expression so
that the corresponding tree temporary can be used as the base
object in gfc_conv_procedure_call. */
if (expr->expr_type != EXPR_VARIABLE)
{
gfc_actual_arglist *args;
for (args= e->value.function.actual; args; args = args->next)
{
if (expr == args->expr)
expr = args->expr;
}
}
/* Since the typebound operators are generic, we have to ensure
that any delays in resolution are corrected and that the vtab
is present. */
@ -5888,9 +5905,26 @@ resolve_typebound_function (gfc_expr* e)
name = name ? name : e->value.function.esym->name;
e->symtree = expr->symtree;
e->ref = gfc_copy_ref (expr->ref);
get_declared_from_expr (&class_ref, NULL, e, false);
/* Trim away the extraneous references that emerge from nested
use of interface.c (extend_expr). */
if (class_ref && class_ref->next)
{
gfc_free_ref_list (class_ref->next);
class_ref->next = NULL;
}
else if (e->ref && !class_ref)
{
gfc_free_ref_list (e->ref);
e->ref = NULL;
}
gfc_add_vptr_component (e);
gfc_add_component_ref (e, name);
e->value.function.esym = NULL;
if (expr->expr_type != EXPR_VARIABLE)
e->base_expr = expr;
return SUCCESS;
}
@ -5901,7 +5935,7 @@ resolve_typebound_function (gfc_expr* e)
return FAILURE;
/* Get the CLASS declared type. */
declared = get_declared_from_expr (&class_ref, &new_ref, e);
declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
/* Weed out cases of the ultimate component being a derived type. */
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
@ -5967,6 +6001,20 @@ resolve_typebound_subroutine (gfc_code *code)
overridable = !code->expr1->value.compcall.tbp->non_overridable;
if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
{
/* If the base_object is not a variable, the corresponding actual
argument expression must be stored in e->base_expression so
that the corresponding tree temporary can be used as the base
object in gfc_conv_procedure_call. */
if (expr->expr_type != EXPR_VARIABLE)
{
gfc_actual_arglist *args;
args= code->expr1->value.function.actual;
for (; args; args = args->next)
if (expr == args->expr)
expr = args->expr;
}
/* Since the typebound operators are generic, we have to ensure
that any delays in resolution are corrected and that the vtab
is present. */
@ -5982,9 +6030,27 @@ resolve_typebound_subroutine (gfc_code *code)
name = name ? name : code->expr1->value.function.esym->name;
code->expr1->symtree = expr->symtree;
code->expr1->ref = gfc_copy_ref (expr->ref);
/* Trim away the extraneous references that emerge from nested
use of interface.c (extend_expr). */
get_declared_from_expr (&class_ref, NULL, code->expr1, false);
if (class_ref && class_ref->next)
{
gfc_free_ref_list (class_ref->next);
class_ref->next = NULL;
}
else if (code->expr1->ref && !class_ref)
{
gfc_free_ref_list (code->expr1->ref);
code->expr1->ref = NULL;
}
/* Now use the procedure in the vtable. */
gfc_add_vptr_component (code->expr1);
gfc_add_component_ref (code->expr1, name);
code->expr1->value.function.esym = NULL;
if (expr->expr_type != EXPR_VARIABLE)
code->expr1->base_expr = expr;
return SUCCESS;
}
@ -5995,7 +6061,7 @@ resolve_typebound_subroutine (gfc_code *code)
return FAILURE;
/* Get the CLASS declared type. */
get_declared_from_expr (&class_ref, &new_ref, code->expr1);
get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
/* Weed out cases of the ultimate component being a derived type. */
if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)

14
gcc/fortran/trans-array.c
View File

@ -1,6 +1,6 @@
/* Array translation routines
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
2011
2011, 2012
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
@ -5069,6 +5069,18 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_add_expr_to_block (&se->pre, tmp);
if (expr->ts.type == BT_CLASS && expr3)
{
tmp = build_int_cst (unsigned_char_type_node, 0);
/* For class objects we need to nullify the memory in case they have
allocatable components; the reason is that _copy, which is used for
initialization, first frees the destination. */
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_MEMSET),
3, pointer, tmp, size);
gfc_add_expr_to_block (&se->pre, tmp);
}
/* Update the array descriptors. */
if (dimension)
gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);

371
gcc/fortran/trans-expr.c
View File

@ -1,6 +1,6 @@
/* Expression translation
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
2011
2011, 2012
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
@ -302,6 +302,179 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
}
static tree
gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
{
gfc_actual_arglist *actual;
gfc_expr *ppc;
gfc_code *ppc_code;
tree res;
actual = gfc_get_actual_arglist ();
actual->expr = gfc_copy_expr (rhs);
actual->next = gfc_get_actual_arglist ();
actual->next->expr = gfc_copy_expr (lhs);
ppc = gfc_copy_expr (obj);
gfc_add_vptr_component (ppc);
gfc_add_component_ref (ppc, "_copy");
ppc_code = gfc_get_code ();
ppc_code->resolved_sym = ppc->symtree->n.sym;
/* Although '_copy' is set to be elemental in class.c, it is
not staying that way. Find out why, sometime.... */
ppc_code->resolved_sym->attr.elemental = 1;
ppc_code->ext.actual = actual;
ppc_code->expr1 = ppc;
ppc_code->op = EXEC_CALL;
/* Since '_copy' is elemental, the scalarizer will take care
of arrays in gfc_trans_call. */
res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
gfc_free_statements (ppc_code);
return res;
}
/* Special case for initializing a polymorphic dummy with INTENT(OUT).
A MEMCPY is needed to copy the full data from the default initializer
of the dynamic type. */
tree
gfc_trans_class_init_assign (gfc_code *code)
{
stmtblock_t block;
tree tmp;
gfc_se dst,src,memsz;
gfc_expr *lhs, *rhs, *sz;
gfc_start_block (&block);
lhs = gfc_copy_expr (code->expr1);
gfc_add_data_component (lhs);
rhs = gfc_copy_expr (code->expr1);
gfc_add_vptr_component (rhs);
/* Make sure that the component backend_decls have been built, which
will not have happened if the derived types concerned have not
been referenced. */
gfc_get_derived_type (rhs->ts.u.derived);
gfc_add_def_init_component (rhs);
if (code->expr1->ts.type == BT_CLASS
&& CLASS_DATA (code->expr1)->attr.dimension)
tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
else
{
sz = gfc_copy_expr (code->expr1);
gfc_add_vptr_component (sz);
gfc_add_size_component (sz);
gfc_init_se (&dst, NULL);
gfc_init_se (&src, NULL);
gfc_init_se (&memsz, NULL);
gfc_conv_expr (&dst, lhs);
gfc_conv_expr (&src, rhs);
gfc_conv_expr (&memsz, sz);
gfc_add_block_to_block (&block, &src.pre);
tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
}
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
/* Translate an assignment to a CLASS object
(pointer or ordinary assignment). */
tree
gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
{
stmtblock_t block;
tree tmp;
gfc_expr *lhs;
gfc_expr *rhs;
gfc_ref *ref;
gfc_start_block (&block);
ref = expr1->ref;
while (ref && ref->next)
ref = ref->next;
/* Class valued proc_pointer assignments do not need any further
preparation. */
if (ref && ref->type == REF_COMPONENT
&& ref->u.c.component->attr.proc_pointer
&& expr2->expr_type == EXPR_VARIABLE
&& expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE
&& op == EXEC_POINTER_ASSIGN)
goto assign;
if (expr2->ts.type != BT_CLASS)
{
/* Insert an additional assignment which sets the '_vptr' field. */
gfc_symbol *vtab = NULL;
gfc_symtree *st;
lhs = gfc_copy_expr (expr1);
gfc_add_vptr_component (lhs);
if (expr2->ts.type == BT_DERIVED)
vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
else if (expr2->expr_type == EXPR_NULL)
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);
gfc_free_expr (lhs);
gfc_free_expr (rhs);
}
else if (CLASS_DATA (expr2)->attr.dimension)
{
/* Insert an additional assignment which sets the '_vptr' field. */
lhs = gfc_copy_expr (expr1);
gfc_add_vptr_component (lhs);
rhs = gfc_copy_expr (expr2);
gfc_add_vptr_component (rhs);
tmp = gfc_trans_pointer_assignment (lhs, rhs);
gfc_add_expr_to_block (&block, tmp);
gfc_free_expr (lhs);
gfc_free_expr (rhs);
}
/* Do the actual CLASS assignment. */
if (expr2->ts.type == BT_CLASS
&& !CLASS_DATA (expr2)->attr.dimension)
op = EXEC_ASSIGN;
else
gfc_add_data_component (expr1);
assign:
if (op == EXEC_ASSIGN)
tmp = gfc_trans_assignment (expr1, expr2, false, true);
else if (op == EXEC_POINTER_ASSIGN)
tmp = gfc_trans_pointer_assignment (expr1, expr2);
else
gcc_unreachable();
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
/* End of prototype trans-class.c */
@ -1976,6 +2149,31 @@ get_proc_ptr_comp (gfc_expr *e)
}
/* Convert a typebound function reference from a class object. */
static void
conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
{
gfc_ref *ref;
tree var;
if (TREE_CODE (base_object) != VAR_DECL)
{
var = gfc_create_var (TREE_TYPE (base_object), NULL);
gfc_add_modify (&se->pre, var, base_object);
}
se->expr = gfc_class_vptr_get (base_object);
se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
ref = expr->ref;
while (ref && ref->next)
ref = ref->next;
gcc_assert (ref && ref->type == REF_COMPONENT);
if (ref->u.c.sym->attr.extension)
conv_parent_component_references (se, ref);
gfc_conv_component_ref (se, ref);
se->expr = build_fold_addr_expr_loc (input_location, se->expr);
}
static void
conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
{
@ -3084,6 +3282,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
tree type;
tree var;
tree len;
tree base_object;
VEC(tree,gc) *stringargs;
tree result = NULL;
gfc_formal_arglist *formal;
@ -3156,6 +3355,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
!= EXPR_CONSTANT);
}
base_object = NULL_TREE;
/* Evaluate the arguments. */
for (arg = args; arg != NULL;
arg = arg->next, formal = formal ? formal->next : NULL)
@ -3301,6 +3502,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
gfc_conv_expr_reference (&parmse, e);
/* Catch base objects that are not variables. */
if (e->ts.type == BT_CLASS
&& e->expr_type != EXPR_VARIABLE
&& expr && e == expr->base_expr)
base_object = build_fold_indirect_ref_loc (input_location,
parmse.expr);
/* A class array element needs converting back to be a
class object, if the formal argument is a class object. */
if (fsym && fsym->ts.type == BT_CLASS
@ -4000,7 +4208,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
arglist = retargs;
/* Generate the actual call. */
conv_function_val (se, sym, expr);
if (base_object == NULL_TREE)
conv_function_val (se, sym, expr);
else
conv_base_obj_fcn_val (se, base_object, expr);
/* If there are alternate return labels, function type should be
integer. Can't modify the type in place though, since it can be shared
@ -5294,7 +5505,6 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
return;
}
gfc_conv_expr (se, expr);
/* Create a temporary var to hold the value. */
@ -6730,158 +6940,3 @@ gfc_trans_assign (gfc_code * code)
{
return gfc_trans_assignment (code->expr1, code->expr2, false, true);
}
static tree
gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
{
gfc_actual_arglist *actual;
gfc_expr *ppc;
gfc_code *ppc_code;
tree res;
actual = gfc_get_actual_arglist ();
actual->expr = gfc_copy_expr (rhs);
actual->next = gfc_get_actual_arglist ();
actual->next->expr = gfc_copy_expr (lhs);
ppc = gfc_copy_expr (obj);
gfc_add_vptr_component (ppc);
gfc_add_component_ref (ppc, "_copy");
ppc_code = gfc_get_code ();
ppc_code->resolved_sym = ppc->symtree->n.sym;
/* Although '_copy' is set to be elemental in class.c, it is
not staying that way. Find out why, sometime.... */
ppc_code->resolved_sym->attr.elemental = 1;
ppc_code->ext.actual = actual;
ppc_code->expr1 = ppc;
ppc_code->op = EXEC_CALL;
/* Since '_copy' is elemental, the scalarizer will take care
of arrays in gfc_trans_call. */
res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
gfc_free_statements (ppc_code);
return res;
}
/* Special case for initializing a polymorphic dummy with INTENT(OUT).
A MEMCPY is needed to copy the full data from the default initializer
of the dynamic type. */
tree
gfc_trans_class_init_assign (gfc_code *code)
{
stmtblock_t block;
tree tmp;
gfc_se dst,src,memsz;
gfc_expr *lhs,*rhs,*sz;
gfc_start_block (&block);
lhs = gfc_copy_expr (code->expr1);
gfc_add_data_component (lhs);
rhs = gfc_copy_expr (code->expr1);
gfc_add_vptr_component (rhs);
/* Make sure that the component backend_decls have been built, which
will not have happened if the derived types concerned have not
been referenced. */
gfc_get_derived_type (rhs->ts.u.derived);
gfc_add_def_init_component (rhs);
if (code->expr1->ts.type == BT_CLASS
&& CLASS_DATA (code->expr1)->attr.dimension)
tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
else
{
sz = gfc_copy_expr (code->expr1);
gfc_add_vptr_component (sz);
gfc_add_size_component (sz);
gfc_init_se (&dst, NULL);
gfc_init_se (&src, NULL);
gfc_init_se (&memsz, NULL);
gfc_conv_expr (&dst, lhs);
gfc_conv_expr (&src, rhs);
gfc_conv_expr (&memsz, sz);
gfc_add_block_to_block (&block, &src.pre);
tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
}
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}
/* Translate an assignment to a CLASS object
(pointer or ordinary assignment). */
tree
gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
{
stmtblock_t block;
tree tmp;
gfc_expr *lhs;
gfc_expr *rhs;
gfc_start_block (&block);
if (expr2->ts.type != BT_CLASS)
{
/* Insert an additional assignment which sets the '_vptr' field. */
gfc_symbol *vtab = NULL;
gfc_symtree *st;
lhs = gfc_copy_expr (expr1);
gfc_add_vptr_component (lhs);
if (expr2->ts.type == BT_DERIVED)
vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
else if (expr2->expr_type == EXPR_NULL)
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);
gfc_free_expr (lhs);
gfc_free_expr (rhs);
}
else if (CLASS_DATA (expr2)->attr.dimension)
{
/* Insert an additional assignment which sets the '_vptr' field. */
lhs = gfc_copy_expr (expr1);
gfc_add_vptr_component (lhs);
rhs = gfc_copy_expr (expr2);
gfc_add_vptr_component (rhs);
tmp = gfc_trans_pointer_assignment (lhs, rhs);
gfc_add_expr_to_block (&block, tmp);
gfc_free_expr (lhs);
gfc_free_expr (rhs);
}
/* Do the actual CLASS assignment. */
if (expr2->ts.type == BT_CLASS && !CLASS_DATA (expr2)->attr.dimension)
op = EXEC_ASSIGN;
else
gfc_add_data_component (expr1);
if (op == EXEC_ASSIGN)
tmp = gfc_trans_assignment (expr1, expr2, false, true);
else if (op == EXEC_POINTER_ASSIGN)
tmp = gfc_trans_pointer_assignment (expr1, expr2);
else
gcc_unreachable();
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
}

8
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,11 @@
2012-01-02 Paul Thomas <pault@gcc.gnu.org>
PR fortran/46262
PR fortran/46328
PR fortran/51052
* gfortran.dg/typebound_operator_7.f03: New.
* gfortran.dg/typebound_operator_8.f03: New.
2012-01-02 Richard Sandiford <rdsandiford@googlemail.com>
PR target/51729

103
gcc/testsuite/gfortran.dg/typebound_operator_7.f03 Normal file
View File

@ -0,0 +1,103 @@
! { dg-do run }
! PR46328 - complex expressions involving typebound operators of class objects.
!
module field_module
implicit none
type ,abstract :: field
contains
procedure(field_op_real) ,deferred :: multiply_real
procedure(field_plus_field) ,deferred :: plus
procedure(assign_field) ,deferred :: assn
generic :: operator(*) => multiply_real
generic :: operator(+) => plus
generic :: ASSIGNMENT(=) => assn
end type
abstract interface
function field_plus_field(lhs,rhs)
import :: field
class(field) ,intent(in) :: lhs
class(field) ,intent(in) :: rhs
class(field) ,allocatable :: field_plus_field
end function
end interface
abstract interface
function field_op_real(lhs,rhs)
import :: field
class(field) ,intent(in) :: lhs
real ,intent(in) :: rhs
class(field) ,allocatable :: field_op_real
end function
end interface
abstract interface
subroutine assign_field(lhs,rhs)
import :: field
class(field) ,intent(OUT) :: lhs
class(field) ,intent(IN) :: rhs
end subroutine
end interface
end module
module i_field_module
use field_module
implicit none
type, extends (field) :: i_field
integer :: i
contains
procedure :: multiply_real => i_multiply_real
procedure :: plus => i_plus_i
procedure :: assn => i_assn
end type
contains
function i_plus_i(lhs,rhs)
class(i_field) ,intent(in) :: lhs
class(field) ,intent(in) :: rhs
class(field) ,allocatable :: i_plus_i
integer :: m = 0
select type (lhs)
type is (i_field); m = lhs%i
end select
select type (rhs)
type is (i_field); m = rhs%i + m
end select
allocate (i_plus_i, source = i_field (m))
end function
function i_multiply_real(lhs,rhs)
class(i_field) ,intent(in) :: lhs
real ,intent(in) :: rhs
class(field) ,allocatable :: i_multiply_real
integer :: m = 0
select type (lhs)
type is (i_field); m = lhs%i * int (rhs)
end select
allocate (i_multiply_real, source = i_field (m))
end function
subroutine i_assn(lhs,rhs)
class(i_field) ,intent(OUT) :: lhs
class(field) ,intent(IN) :: rhs
select type (lhs)
type is (i_field)
select type (rhs)
type is (i_field)
lhs%i = rhs%i
end select
end select
end subroutine
end module
program main
use i_field_module
implicit none
class(i_field) ,allocatable :: u
allocate (u, source = i_field (99))
u = u*2.
u = (u*2.0*4.0) + u*4.0
u = u%multiply_real (2.0)*4.0
u = i_multiply_real (u, 2.0) * 4.0
select type (u)
type is (i_field); if (u%i .ne. 152064) call abort
end select
end program
! { dg-final { cleanup-modules "field_module i_field_module" } }

499
gcc/testsuite/gfortran.dg/typebound_operator_8.f03 Normal file
View File

@ -0,0 +1,499 @@
! { dg-do run }
!
! Solve a diffusion problem using an object-oriented approach
!
! Author: Arjen Markus (comp.lang.fortran)
! This version: pault@gcc.gnu.org
!
! Note:
! (i) This could be turned into a more sophisticated program
! using the techniques described in the chapter on
! mathematical abstractions.
! (That would allow the selection of the time integration
! method in a transparent way)
!
! (ii) The target procedures for process_p and source_p are
! different to the typebound procedures for dynamic types
! because the passed argument is not type(base_pde_object).
!
! (iii) Two solutions are calculated, one with the procedure
! pointers and the other with typebound procedures. The sums
! of the solutions are compared.
! (iv) The source is a delta function in the middle of the
! mesh, whilst the process is quartic in the local value,
! when it is positive.
!
! base_pde_objects --
! Module to define the basic objects
!
module base_pde_objects
implicit none
type, abstract :: base_pde_object
! No data
procedure(process_p), pointer, pass :: process_p
procedure(source_p), pointer, pass :: source_p
contains
procedure(process), deferred :: process
procedure(source), deferred :: source
procedure :: initialise
procedure :: nabla2
procedure :: print
procedure(real_times_obj), pass(obj), deferred :: real_times_obj
procedure(obj_plus_obj), deferred :: obj_plus_obj
procedure(obj_assign_obj), deferred :: obj_assign_obj
generic :: operator(*) => real_times_obj
generic :: operator(+) => obj_plus_obj
generic :: assignment(=) => obj_assign_obj
end type
abstract interface
function process_p (obj)
import base_pde_object
class(base_pde_object), intent(in) :: obj
class(base_pde_object), allocatable :: process_p
end function process_p
end interface
abstract interface
function source_p (obj, time)
import base_pde_object
class(base_pde_object), intent(in) :: obj
real, intent(in) :: time
class(base_pde_object), allocatable :: source_p
end function source_p
end interface
abstract interface
function process (obj)
import base_pde_object
class(base_pde_object), intent(in) :: obj
class(base_pde_object), allocatable :: process
end function process
end interface
abstract interface
function source (obj, time)
import base_pde_object
class(base_pde_object), intent(in) :: obj
real, intent(in) :: time
class(base_pde_object), allocatable :: source
end function source
end interface
abstract interface
function real_times_obj (factor, obj) result(newobj)
import base_pde_object
real, intent(in) :: factor
class(base_pde_object), intent(in) :: obj
class(base_pde_object), allocatable :: newobj
end function real_times_obj
end interface
abstract interface
function obj_plus_obj (obj1, obj2) result(newobj)
import base_pde_object
class(base_pde_object), intent(in) :: obj1
class(base_pde_object), intent(in) :: obj2
class(base_pde_object), allocatable :: newobj
end function obj_plus_obj
end interface
abstract interface
subroutine obj_assign_obj (obj1, obj2)
import base_pde_object
class(base_pde_object), intent(inout) :: obj1
class(base_pde_object), intent(in) :: obj2
end subroutine obj_assign_obj
end interface
contains
! print --
! Print the concentration field
subroutine print (obj)
class(base_pde_object) :: obj
! Dummy
end subroutine print
! initialise --
! Initialise the concentration field using a specific function
subroutine initialise (obj, funcxy)
class(base_pde_object) :: obj
interface
real function funcxy (coords)
real, dimension(:), intent(in) :: coords
end function funcxy
end interface
! Dummy
end subroutine initialise
! nabla2 --
! Determine the divergence
function nabla2 (obj)
class(base_pde_object), intent(in) :: obj
class(base_pde_object), allocatable :: nabla2
! Dummy
end function nabla2
end module base_pde_objects
! cartesian_2d_objects --
! PDE object on a 2D cartesian grid
!
module cartesian_2d_objects
use base_pde_objects
implicit none
type, extends(base_pde_object) :: cartesian_2d_object
real, dimension(:,:), allocatable :: c
real :: dx
real :: dy
contains
procedure :: process => process_cart2d
procedure :: source => source_cart2d
procedure :: initialise => initialise_cart2d
procedure :: nabla2 => nabla2_cart2d
procedure :: print => print_cart2d
procedure, pass(obj) :: real_times_obj => real_times_cart2d
procedure :: obj_plus_obj => obj_plus_cart2d
procedure :: obj_assign_obj => obj_assign_cart2d
end type cartesian_2d_object
interface grid_definition
module procedure grid_definition_cart2d
end interface
contains
function process_cart2d (obj)
class(cartesian_2d_object), intent(in) :: obj
class(base_pde_object), allocatable :: process_cart2d
allocate (process_cart2d,source = obj)
select type (process_cart2d)
type is (cartesian_2d_object)
process_cart2d%c = -sign (obj%c, 1.0)*obj%c** 4
class default
call abort
end select
end function process_cart2d
function process_cart2d_p (obj)
class(base_pde_object), intent(in) :: obj
class(base_pde_object), allocatable :: process_cart2d_p
allocate (process_cart2d_p,source = obj)
select type (process_cart2d_p)
type is (cartesian_2d_object)
select type (obj)
type is (cartesian_2d_object)
process_cart2d_p%c = -sign (obj%c, 1.0)*obj%c** 4
end select
class default
call abort
end select
end function process_cart2d_p
function source_cart2d (obj, time)
class(cartesian_2d_object), intent(in) :: obj
real, intent(in) :: time
class(base_pde_object), allocatable :: source_cart2d
integer :: m, n
m = size (obj%c, 1)
n = size (obj%c, 2)
allocate (source_cart2d, source = obj)
select type (source_cart2d)
type is (cartesian_2d_object)
if (allocated (source_cart2d%c)) deallocate (source_cart2d%c)
allocate (source_cart2d%c(m, n))
source_cart2d%c = 0.0
if (time .lt. 5.0) source_cart2d%c(m/2, n/2) = 0.1
class default
call abort
end select
end function source_cart2d
function source_cart2d_p (obj, time)
class(base_pde_object), intent(in) :: obj
real, intent(in) :: time
class(base_pde_object), allocatable :: source_cart2d_p
integer :: m, n
select type (obj)
type is (cartesian_2d_object)
m = size (obj%c, 1)
n = size (obj%c, 2)
class default
call abort
end select
allocate (source_cart2d_p,source = obj)
select type (source_cart2d_p)
type is (cartesian_2d_object)
if (allocated (source_cart2d_p%c)) deallocate (source_cart2d_p%c)
allocate (source_cart2d_p%c(m,n))
source_cart2d_p%c = 0.0
if (time .lt. 5.0) source_cart2d_p%c(m/2, n/2) = 0.1
class default
call abort
end select
end function source_cart2d_p
! grid_definition --
! Initialises the grid
!
subroutine grid_definition_cart2d (obj, sizes, dims)
class(base_pde_object), allocatable :: obj
real, dimension(:) :: sizes
integer, dimension(:) :: dims
allocate( cartesian_2d_object :: obj )
select type (obj)
type is (cartesian_2d_object)
allocate (obj%c(dims(1), dims(2)))
obj%c = 0.0
obj%dx = sizes(1)/dims(1)
obj%dy = sizes(2)/dims(2)
class default
call abort
end select
end subroutine grid_definition_cart2d
! print_cart2d --
! Print the concentration field to the screen
!
subroutine print_cart2d (obj)
class(cartesian_2d_object) :: obj
character(len=20) :: format
write( format, '(a,i0,a)' ) '(', size(obj%c,1), 'f6.3)'
write( *, format ) obj%c
end subroutine print_cart2d
! initialise_cart2d --
! Initialise the concentration field using a specific function
!
subroutine initialise_cart2d (obj, funcxy)
class(cartesian_2d_object) :: obj
interface
real function funcxy (coords)
real, dimension(:), intent(in) :: coords
end function funcxy
end interface
integer :: i, j
real, dimension(2) :: x
obj%c = 0.0
do j = 2,size (obj%c, 2)-1
x(2) = obj%dy * (j-1)
do i = 2,size (obj%c, 1)-1
x(1) = obj%dx * (i-1)
obj%c(i,j) = funcxy (x)
enddo
enddo
end subroutine initialise_cart2d
! nabla2_cart2d
! Determine the divergence
function nabla2_cart2d (obj)
class(cartesian_2d_object), intent(in) :: obj
class(base_pde_object), allocatable :: nabla2_cart2d
integer :: m, n
real :: dx, dy
m = size (obj%c, 1)
n = size (obj%c, 2)
dx = obj%dx
dy = obj%dy
allocate (cartesian_2d_object :: nabla2_cart2d)
select type (nabla2_cart2d)
type is (cartesian_2d_object)
allocate (nabla2_cart2d%c(m,n))
nabla2_cart2d%c = 0.0
nabla2_cart2d%c(2:m-1,2:n-1) = &
-(2.0 * obj%c(2:m-1,2:n-1) - obj%c(1:m-2,2:n-1) - obj%c(3:m,2:n-1)) / dx**2 &
-(2.0 * obj%c(2:m-1,2:n-1) - obj%c(2:m-1,1:n-2) - obj%c(2:m-1,3:n)) / dy**2
class default
call abort
end select
end function nabla2_cart2d
function real_times_cart2d (factor, obj) result(newobj)
real, intent(in) :: factor
class(cartesian_2d_object), intent(in) :: obj
class(base_pde_object), allocatable :: newobj
integer :: m, n
m = size (obj%c, 1)
n = size (obj%c, 2)
allocate (cartesian_2d_object :: newobj)
select type (newobj)
type is (cartesian_2d_object)
allocate (newobj%c(m,n))
newobj%c = factor * obj%c
class default
call abort
end select
end function real_times_cart2d
function obj_plus_cart2d (obj1, obj2) result( newobj )
class(cartesian_2d_object), intent(in) :: obj1
class(base_pde_object), intent(in) :: obj2
class(base_pde_object), allocatable :: newobj
integer :: m, n
m = size (obj1%c, 1)
n = size (obj1%c, 2)
allocate (cartesian_2d_object :: newobj)
select type (newobj)
type is (cartesian_2d_object)
allocate (newobj%c(m,n))
select type (obj2)
type is (cartesian_2d_object)
newobj%c = obj1%c + obj2%c
class default
call abort
end select
class default
call abort
end select
end function obj_plus_cart2d
subroutine obj_assign_cart2d (obj1, obj2)
class(cartesian_2d_object), intent(inout) :: obj1
class(base_pde_object), intent(in) :: obj2
select type (obj2)
type is (cartesian_2d_object)
obj1%c = obj2%c
class default
call abort
end select
end subroutine obj_assign_cart2d
end module cartesian_2d_objects
! define_pde_objects --
! Module to bring all the PDE object types together
!
module define_pde_objects
use base_pde_objects
use cartesian_2d_objects
implicit none
interface grid_definition
module procedure grid_definition_general
end interface
contains
subroutine grid_definition_general (obj, type, sizes, dims)
class(base_pde_object), allocatable :: obj
character(len=*) :: type
real, dimension(:) :: sizes
integer, dimension(:) :: dims
select case (type)
case ("cartesian 2d")
call grid_definition (obj, sizes, dims)
case default
write(*,*) 'Unknown grid type: ', trim (type)
stop
end select
end subroutine grid_definition_general
end module define_pde_objects
! pde_specific --
! Module holding the routines specific to the PDE that
! we are solving
!
module pde_specific
implicit none
contains
real function patch (coords)
real, dimension(:), intent(in) :: coords
if (sum ((coords-[50.0,50.0])**2) < 40.0) then
patch = 1.0
else
patch = 0.0
endif
end function patch
end module pde_specific
! test_pde_solver --
! Small test program to demonstrate the usage
!
program test_pde_solver
use define_pde_objects
use pde_specific
implicit none
class(base_pde_object), allocatable :: solution, deriv
integer :: i
real :: time, dtime, diff, chksum(2)
call simulation1 ! Use proc pointers for source and process define_pde_objects
select type (solution)
type is (cartesian_2d_object)
deallocate (solution%c)
end select
select type (deriv)
type is (cartesian_2d_object)
deallocate (deriv%c)
end select
deallocate (solution, deriv)
call simulation2 ! Use typebound procedures for source and process
if (chksum(1) .ne. chksum(2)) call abort
if ((chksum(1) - 0.881868720)**2 > 1e-4) call abort
contains
subroutine simulation1
!
! Create the grid
!
call grid_definition (solution, "cartesian 2d", [100.0, 100.0], [16, 16])
call grid_definition (deriv, "cartesian 2d", [100.0, 100.0], [16, 16])
!
! Initialise the concentration field
!
call solution%initialise (patch)
!
! Set the procedure pointers
!
solution%source_p => source_cart2d_p
solution%process_p => process_cart2d_p
!
! Perform the integration - explicit method
!
time = 0.0
dtime = 0.1
diff = 5.0e-3
! Give the diffusion coefficient correct dimensions.
select type (solution)
type is (cartesian_2d_object)
diff = diff * solution%dx * solution%dy / dtime
end select
! write(*,*) 'Time: ', time, diff
! call solution%print
do i = 1,100
deriv = solution%nabla2 ()
solution = solution + diff * dtime * deriv + solution%source_p (time) + solution%process_p ()
! if ( mod(i, 25) == 0 ) then
! write(*,*)'Time: ', time
! call solution%print
! endif
time = time + dtime
enddo
! write(*,*) 'End result 1: '
! call solution%print
select type (solution)
type is (cartesian_2d_object)
chksum(1) = sum (solution%c)
end select
end subroutine
subroutine simulation2
!
! Create the grid
!
call grid_definition (solution, "cartesian 2d", [100.0, 100.0], [16, 16])
call grid_definition (deriv, "cartesian 2d", [100.0, 100.0], [16, 16])
!
! Initialise the concentration field
!
call solution%initialise (patch)
!
! Set the procedure pointers
!
solution%source_p => source_cart2d_p
solution%process_p => process_cart2d_p
!
! Perform the integration - explicit method
!
time = 0.0
dtime = 0.1
diff = 5.0e-3
! Give the diffusion coefficient correct dimensions.
select type (solution)
type is (cartesian_2d_object)
diff = diff * solution%dx * solution%dy / dtime
end select
! write(*,*) 'Time: ', time, diff
! call solution%print
do i = 1,100
deriv = solution%nabla2 ()
solution = solution + diff * dtime * deriv + solution%source (time) + solution%process ()
! if ( mod(i, 25) == 0 ) then
! write(*,*)'Time: ', time
! call solution%print
! endif
time = time + dtime
enddo
! write(*,*) 'End result 2: '
! call solution%print
select type (solution)
type is (cartesian_2d_object)
chksum(2) = sum (solution%c)
end select
end subroutine
end program test_pde_solver
! { dg-final { cleanup-modules "pde_specific define_pde_objects cartesian_2d_objects base_pde_objects" } }