From 94fae14bf8aa693c31a8d19febfffd048edb9535 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Mon, 2 Jan 2012 12:46:08 +0000 Subject: [PATCH] re PR fortran/51529 ([OOP] gfortran.dg/class_to_type_1.f03 is miscompiled: Uninitialized variable used) 2012-01-02 Paul Thomas 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 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 --- gcc/fortran/ChangeLog | 30 ++ gcc/fortran/dump-parse-tree.c | 1 + gcc/fortran/gfortran.h | 6 +- gcc/fortran/interface.c | 10 +- gcc/fortran/resolve.c | 84 ++- gcc/fortran/trans-array.c | 14 +- gcc/fortran/trans-expr.c | 371 +++++++------ gcc/testsuite/ChangeLog | 8 + .../gfortran.dg/typebound_operator_7.f03 | 103 ++++ .../gfortran.dg/typebound_operator_8.f03 | 499 ++++++++++++++++++ 10 files changed, 956 insertions(+), 170 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/typebound_operator_7.f03 create mode 100644 gcc/testsuite/gfortran.dg/typebound_operator_8.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index af5fd93a6f0..02c0def3cda 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,33 @@ +2012-01-02 Paul Thomas + + 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 PR fortran/51682 diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index af2cd85a561..c715b30d397 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -2330,3 +2330,4 @@ gfc_dump_parse_tree (gfc_namespace *ns, FILE *file) dumpfile = file; show_namespace (ns); } + diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index daa28965189..5923069996b 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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; diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index e914c6c7910..773749d5ebc 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -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; + } } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 0c27b2360b0..82045f8ea23 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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) diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index a6443129156..50e1ee422f9 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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 and Steven Bosscher @@ -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); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 83d8087fd50..2ffa9fc2af7 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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 and Steven Bosscher @@ -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); -} diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index fe6a6002cb2..e24d96c4522 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2012-01-02 Paul Thomas + + 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 PR target/51729 diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_7.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_7.f03 new file mode 100644 index 00000000000..c61a00c6671 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_operator_7.f03 @@ -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" } } + diff --git a/gcc/testsuite/gfortran.dg/typebound_operator_8.f03 b/gcc/testsuite/gfortran.dg/typebound_operator_8.f03 new file mode 100644 index 00000000000..9519e98abb0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_operator_8.f03 @@ -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" } } -- 2.30.2