Message ID | CAGkQGiKUfxLdbGaC0Xa=xs9BZiybvJBBvyjnEPLnoqrjyZUTyw@mail.gmail.com |
---|---|
State | New |
Headers | show |
Am 10.09.2012 20:58, schrieb Paul Richard Thomas:
> Bootstrapped and regtested on FC9/x86_64 - OK for trunk?
The following test case doesn't work; it should print "Overloaded" - and
does so with crayftn. But with your patch, it doesn't.
Tobias
module a_mod
type :: a
contains
procedure :: a_ass
generic :: assignment(=) => a_ass
end type a
type c
type(a) :: ta
end type c
type :: b
type(c) :: tc
end type b
contains
impure elemental subroutine a_ass(out, in)
class(a), intent(out) :: out
type(a), intent(in) :: in
print *, "Overloaded"
end subroutine a_ass
end module a_mod
program assign
use a_mod
type(b) :: tt
type(b) :: tb1
tt = tb1
end program assign
+ build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2, +
gfc_component *comp1, gfc_component *comp2, locus loc)
For comp1/comp2, I am wondering whether one shouldn't add a
gcc_assert ((comp1 && comp2) || (!comp1 && !comp2));
+ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
Not that we make so much use of it, but its symbol could be a candidate
for attr.artificial. (I don't know whether it should.)
Dear Tobias, > The following test case doesn't work; it should print "Overloaded" - and > does so with crayftn. But with your patch, it doesn't. For some reason, I guess, the attribute defined_assign_comp is not getting passed along to type 'b'. > + build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2, + > gfc_component *comp1, gfc_component *comp2, locus loc) > > For comp1/comp2, I am wondering whether one shouldn't add a > gcc_assert ((comp1 && comp2) || (!comp1 && !comp2)); I guess that it will do no harm and might be advised if this function is called from elsewhere. > > > + get_temp_from_expr (gfc_expr *e, gfc_namespace *ns) > > Not that we make so much use of it, but its symbol could be a candidate for > attr.artificial. (I don't know whether it should.) I don't know either. I don't recall even noticing the artificial attribute. I will follow it up to see what use is made of it and see if it applies here. Presumably this couples directly to DECL_ARTIFICIAL? Thanks for the review. Paul PS I really, really want to get used to this PR! PPS I presume that the reason for two temporaries is clear to you?
Hello, On 10/09/2012 20:58, Paul Richard Thomas wrote: > Dear All, > > Please find attached a new attempt at the patch for PR46897. It now > uses temporaries to overcome the side effects that Mikael pointed out. And here comes the next round of comments. > Index: gcc/fortran/resolve.c > =================================================================== > *** gcc/fortran/resolve.c (revision 191115) > --- gcc/fortran/resolve.c (working copy) > *************** resolve_ordinary_assign (gfc_code *code, > *** 9516,9521 **** > --- 9516,9791 ---- > } > > > + /* Add a component reference onto an expression. */ > + > + static void > + add_comp_ref (gfc_expr *e, gfc_component *c) > + { > + gfc_ref **ref; > + ref = &(e->ref); > + while (*ref) > + ref = &((*ref)->next); > + *ref = gfc_get_ref(); > + (*ref)->type = REF_COMPONENT; > + (*ref)->u.c.sym = e->ts.u.derived; > + (*ref)->u.c.component = c; > + e->ts = c->ts; > + > + /* Add a full array ref, as necessary. */ > + e->rank = c && c->as ? c->as->rank : 0; This is bogus if e->rank was != 0 previously (think of the case array(:)%scalar_comp). The c == NULL case should be handled at the beginning (if at all). > + if (e->rank) the condition should be on c->as (for the case array(:)%scalar_comp again). > + gfc_add_full_array_ref (e, c->as); > + } > + > + > + /* Build an assignment. */ > + > + static gfc_code * > + build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2, > + gfc_component *comp1, gfc_component *comp2, locus loc) > + { > + gfc_code *this_code; > + > + this_code = gfc_get_code (); > + this_code->op = op; all calls are with op == EXEC_ASSIGN, you may as well hardcode it. > + this_code->next = NULL; > + this_code->expr1 = gfc_copy_expr (expr1); > + this_code->expr2 = gfc_copy_expr (expr2); > + this_code->loc = loc; > + if (comp1 && comp2) > + { > + add_comp_ref (this_code->expr1, comp1); > + add_comp_ref (this_code->expr2, comp2); > + } > + > + return this_code; > + } > + > + > + /* Makes a temporary variable expression based on the characteristics of > + a given expression. */ > + > + static gfc_expr* > + get_temp_from_expr (gfc_expr *e, gfc_namespace *ns) > + { > + static int serial = 0; > + char name[GFC_MAX_SYMBOL_LEN]; > + gfc_symtree *tmp; > + gfc_ref *ref = NULL, *eref; > + > + gcc_assert (e->expr_type == EXPR_VARIABLE > + || e->expr_type == EXPR_FUNCTION); As far as I know anything can be used, not only variables and functions. The derived type cases are a bit specific but at least array/structure constructors are missing. There could be also typebound function calls (I never know whether they are EXPR_FUNCTION or something else). > + sprintf (name, "da@%d", serial++); > + gfc_get_sym_tree (name, ns, &tmp, false); > + gfc_add_type (tmp->n.sym, &e->ts, NULL); > + > + for (eref = e->ref; eref; eref = eref->next) > + if (eref->type == REF_COMPONENT) > + ref = eref; > + > + if (!ref) > + { > + tmp->n.sym->attr = e->symtree->n.sym->attr; > + if (e->symtree->n.sym->as) > + tmp->n.sym->as > + = gfc_copy_array_spec (e->symtree->n.sym->as); > + } > + else > + { > + tmp->n.sym->attr = ref->u.c.component->attr; > + if (ref->u.c.component->as) > + tmp->n.sym->as > + = gfc_copy_array_spec (ref->u.c.component->as); > + } > + > + gfc_set_sym_referenced (tmp->n.sym); > + gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); > + return gfc_lval_expr_from_sym (tmp->n.sym); > + } > + > + > + /* Add one line of code to the code chain, making sure that 'head' and > + 'tail' are appropriately updated. */ > + > + static void > + add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail) > + { > + gcc_assert (this_code); > + if (*head == NULL) > + *head = *tail = *this_code; > + else > + *tail = gfc_append_code (*tail, *this_code); > + *this_code = NULL; > + } > + > + > + /* Implement 7.2.1.3 of the F08 standard: > + "An intrinsic assignment where the variable is of derived type is > + performed as if each component of the variable were assigned from the > + corresponding component of expr using pointer assignment (7.2.2) for > + each pointer component, defined assignment for each nonpointer > + nonallocatable component of a type that has a type-bound defined > + assignment consistent with the component, intrinsic assignment for > + each other nonpointer nonallocatable component, ..." > + > + The pointer assignments are taken care of by the intrinsic > + assignment of the structure itself. This function recursively adds > + defined assignments where required. > + > + Since the lhs in a defined assignment can have intent INOUT, the code > + to do this gets a bit messy. In pseudo-code: > + > + ! Only call function lhs once. > + if (lhs is a function) > + temp_x = expr2 > + expr2 = expr(temp_x) > + ! Need two temporaries for lhs. > + t1 = expr1 > + t2 = expr2 > + ! Do the intrinsic assignment > + expr1 = expr2 > + ! Now do the defined assignments > + do over components with typebound defined assignment [%cmp] > + expr2%cmp {defined=} t1%cmp I guess it should be `t1%cmp {defined=} expr2%cmp'? > + expr1%cmp = t1%cmp ! Store in the result > + t1%cmp = t2%cmp ! Restore the original value It seems to me that the last assignment isn't useful: once one component has been taken care of, we proceed with the next one, so `t1' can have garbage in the previous one without any impact. Then if it can be removed, `t2' is useless and then `temp_x' as well, so we could do with the simpler [still most of `t1' is useless]: t1 = expr1 expr1 = expr2 t1%cmp {defined=} expr1%cmp expr1%cmp = t1%cmp It would be nice too if the temporaries were avoided in the case there is no defined assignment with intent(inout) lhs, but I leave the decision to do it to you. > + */ > + > + static void > + generate_component_assignments (gfc_code **code, gfc_namespace *ns) > + { > + gfc_component *comp1, *comp2; > + gfc_code *this_code = NULL, *head = NULL, *tail = NULL; > + gfc_expr *t1, *t2; > + > + /* Filter out continuing processing after an error. */ > + if ((*code)->expr1->ts.type != BT_DERIVED > + || (*code)->expr2->ts.type != BT_DERIVED) > + return; > + > + /* Create a temporary so that functions get called once. */ > + if ((*code)->expr2->expr_type != EXPR_VARIABLE) > + { > + gfc_expr *tmp_expr; > + > + /* Assign the rhs to the temporary. */ > + tmp_expr = get_temp_from_expr ((*code)->expr1, ns); > + this_code = build_assignment (EXEC_ASSIGN, > + tmp_expr, (*code)->expr2, > + NULL, NULL, (*code)->loc); > + > + /* Add the code and substitute the rhs expression. */ > + add_code_to_chain (&this_code, &head, &tail); > + gfc_free_expr ((*code)->expr2); > + (*code)->expr2 = tmp_expr; > + } > + > + /* Build the two temporaries required for the assignment. */ > + t1 = get_temp_from_expr ((*code)->expr1, ns); > + this_code = build_assignment (EXEC_ASSIGN, > + t1, (*code)->expr1, > + NULL, NULL, (*code)->loc); > + add_code_to_chain (&this_code, &head, &tail); > + t2 = get_temp_from_expr ((*code)->expr1, ns); > + this_code = build_assignment (EXEC_ASSIGN, > + t2, (*code)->expr1, > + NULL, NULL, (*code)->loc); > + add_code_to_chain (&this_code, &head, &tail); > + > + /* Do the intrinsic assignment. This is not needed if the lhs is one > + of the temporaries generated here, since the intrinsic assignment > + to the final result already does this. */ > + if ((*code)->expr1->symtree->n.sym->name[2] != '@') > + { > + this_code = build_assignment (EXEC_ASSIGN, > + (*code)->expr1, (*code)->expr2, > + NULL, NULL, (*code)->loc); > + add_code_to_chain (&this_code, &head, &tail); > + } > + > + comp1 = (*code)->expr1->ts.u.derived->components; > + comp2 = (*code)->expr2->ts.u.derived->components; > + > + for (; comp1; comp1 = comp1->next, comp2 = comp2->next) > + { > + /* The intrinsic assignment does the right thing for pointers > + of all kinds and allocatable components. */ > + if (comp1->ts.type != BT_DERIVED > + || comp1->attr.pointer > + || comp1->attr.allocatable > + || comp1->attr.proc_pointer_comp That one doesn't look right. > + || comp1->attr.class_pointer > + || comp1->attr.proc_pointer) > + continue; > + > + if (this_code) > + add_code_to_chain (&this_code, &head, &tail); > + > + /* Make an assigment for this component. */ > + this_code = gfc_get_code (); > + this_code = build_assignment (EXEC_ASSIGN, > + t1, (*code)->expr2, > + comp1, comp2, (*code)->loc); > + > + /* Convert the assignment if there is a defined assignment for > + this type. Otherwise, using the call from resolve_code, > + recurse into its components. */ > + resolve_code (this_code, ns); > + > + if (this_code->op == EXEC_ASSIGN_CALL) > + { > + /* Check that there is a typebound defined assignment. If not, > + then this must be a module defined assignment. We cannot > + use the defined_assign_comp attribute here because it must > + be this derived type that has the defined assignment and not > + a parent type. */ > + if (!(comp1->ts.u.derived->f2k_derived > + && comp1->ts.u.derived->f2k_derived > + ->tb_op[INTRINSIC_ASSIGN])) > + { > + gfc_free_statements (this_code); `this_code' should be cleared, otherwise it is used in the next iteration. > + continue; > + } > + } > + else if (this_code->op == EXEC_ASSIGN && !this_code->next) > + { > + /* Don't add intrinsic assignments since they are already > + effected by the intrinsic assignment of the structure. */ > + gfc_free_statements (this_code); Same. > + continue; > + } > + > + add_code_to_chain (&this_code, &head, &tail); > + > + /* Transfer the value to the final result. */ > + this_code = build_assignment (EXEC_ASSIGN, > + (*code)->expr1, t1, > + comp1, comp2, (*code)->loc); > + add_code_to_chain (&this_code, &head, &tail); > + > + /* Restore the value of t1. This code is added to the chain at > + the start of the loop if more defined assignments. */ > + this_code = build_assignment (EXEC_ASSIGN, > + t1, t2, > + comp1, comp2, (*code)->loc); > + } > + > + if (this_code) > + gfc_free_statements (this_code); > + > + /* Now attach the remaining code chain to the input code. Step on > + to the end of the new code since resolution is complete. */ > + gcc_assert ((*code)->op == EXEC_ASSIGN); > + tail->next = (*code)->next; > + /* Overwrite 'code' because this would place the intrinsic assignment > + before the temporary for the lhs is created. */ > + gfc_free_expr ((*code)->expr1); > + gfc_free_expr ((*code)->expr2); > + **code = *head; free (head); ? > + *code = tail; > + } > + > + > /* Given a block of code, recursively resolve everything pointed to by this > code block. */ > > *************** resolve_code (gfc_code *code, gfc_namesp > *** 9678,9683 **** > --- 9948,9959 ---- > else > goto call; > } > + > + /* F03 7.4.1.3 for non-allocatable, non-pointer components. */ > + if (code->expr1->ts.type == BT_DERIVED > + && code->expr1->ts.u.derived->attr.defined_assign_comp) > + generate_component_assignments (&code, ns); > + > break; > > case EXEC_LABEL_ASSIGN: > *************** resolve_fl_derived0 (gfc_symbol *sym) > *** 12282,12289 **** > --- 12558,12574 ---- > || c->attr.proc_pointer > || c->attr.allocatable)) == FAILURE) > return FAILURE; > + > + if (c->ts.type == BT_DERIVED > + && c->ts.u.derived->f2k_derived > + && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]) > + sym->attr.defined_assign_comp = 1; > } > > + if (super_type) > + sym->attr.defined_assign_comp > + = super_type->attr.defined_assign_comp; I guess Tobias' reported bug is here. The flag shouldn't be cleared here if it was set just before. > + > /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that > all DEFERRED bindings are overridden. */ > if (super_type && super_type->attr.abstract && !sym->attr.abstract To finish, I would like to draw your attention on the scalarizer not supporting multiple arrays in the reference chain. The initial expressions are guaranteed to have at most one array in the chain, but as we add subfield references, that condition can not remain true. We could try adding multiple references support in the scalarizer, but I don't know how difficult it would be. Or maybe better fix it at the front-end AST level by using elemental functions to split the scalarization work. Or something else. What do you think? Mikael
On 17/09/2012 20:45, Mikael Morin wrote: >> *************** resolve_fl_derived0 (gfc_symbol *sym) >> *** 12282,12289 **** >> --- 12558,12574 ---- >> || c->attr.proc_pointer >> || c->attr.allocatable)) == FAILURE) >> return FAILURE; >> + >> + if (c->ts.type == BT_DERIVED >> + && c->ts.u.derived->f2k_derived >> + && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]) >> + sym->attr.defined_assign_comp = 1; >> } >> >> + if (super_type) >> + sym->attr.defined_assign_comp >> + = super_type->attr.defined_assign_comp; > I guess Tobias' reported bug is here. The flag shouldn't be cleared > here if it was set just before. Or maybe it is just before, as it doesn't check c->ts.u.derived->attr.defined_assign_comp
Dear Mikael, Thanks for the usually thorough review. ....snip.... > And here comes the next round of comments. ....snip.... >> + e->rank = c && c->as ? c->as->rank : 0; > This is bogus if e->rank was != 0 previously (think of the case > array(:)%scalar_comp). mistaken maybe but not bogus! > The c == NULL case should be handled at the beginning (if at all). > >> + if (e->rank) > the condition should be on c->as (for the case array(:)%scalar_comp again). OK point taken. ....snip... >> + this_code->op = op; > all calls are with op == EXEC_ASSIGN, you may as well hardcode it. I thought to leave it general so that the function could be reused for other purposes. ....snip... . >> + gcc_assert (e->expr_type == EXPR_VARIABLE >> + || e->expr_type == EXPR_FUNCTION); > As far as I know anything can be used, not only variables and functions. > The derived type cases are a bit specific but at least array/structure > constructors are missing. There could be also typebound function calls > (I never know whether they are EXPR_FUNCTION or something else). The reason for this assert is the later use of e->symtree. I'll see what I can do to generalise it. ....snip.... > I guess it should be `t1%cmp {defined=} expr2%cmp'? mmmm..... it might just be >> + || comp1->attr.proc_pointer_comp > That one doesn't look right. Why not? > `this_code' should be cleared, otherwise it is used in the next iteration. I'll check that this is not done in gfc_free_statements (no source to hand at the moment) - I believe that it is. ....snip... >> + = super_type->attr.defined_assign_comp; > I guess Tobias' reported bug is here. The flag shouldn't be cleared > here if it was set just before. > I am sure that it is in this vicinity.... :-) > > To finish, I would like to draw your attention on the scalarizer not > supporting multiple arrays in the reference chain. The initial > expressions are guaranteed to have at most one array in the chain, but > as we add subfield references, that condition can not remain true. We > could try adding multiple references support in the scalarizer, but I > don't know how difficult it would be. Or maybe better fix it at the > front-end AST level by using elemental functions to split the > scalarization work. Or something else. What do you think? resolve_expr punts on this, does it not? I'll check. I cannot conceivably come back to this for a week or so because daytime and private life are overwhelmingly hectic (wife and daughter moving back to UK). Thanks again Paul
On 19/09/2012 20:46, Paul Richard Thomas wrote: >>> + || comp1->attr.proc_pointer_comp >> That one doesn't look right. > > Why not? It skips any component containing a procedure pointer subcomponent. Actually, from looking at parse.c where the flag is set, it seems that the flag is only set for derived types, not for components, so it's not that bad; the condition never triggers. > >> `this_code' should be cleared, otherwise it is used in the next iteration. > I'll check that this is not done in gfc_free_statements (no source to > hand at the moment) - I believe that it is. To be clear, the _pointer_ should be cleared: this_code = NULL; Mikael
Dear Mikael, Thank you for the last review of my patch for this PR. Since then, I have had difficulty to find time for gfortran for both personal and professional reasons. Anyway, the attached is my attempt to remedy the problems that you identified. In a moment of madness, I clicked on "remove trailing white space"... well, you can see the result! Fortunately, all the meat of the patch in a contiguous chunk so you just have to search for "add_comp_ref" and you are there. I THINK that this is pretty complete but you all proved me wrong last time, so I am just awaiting the contradictions to that statement :-( Array sections on the lhs are not handled as well as might be hoped, when an lhs temporary is needed; the temporary comprises the full array and the section is explicitly referenced. Fortunately, it is rare that memory is a problem these days so I have let it be. Should need arise, the temporary could be made allocatable and ALLOCATE called explicitly (my attempts to use the reallocate on assign mechanism failed for reasons that I could not see. I'll try again some other time.) Note that I have had to punt on defined assignments when there is more than one part reference involved. The warning message suggests making the loops explicit to make the defined assignment work. I have made responses to your review below. I also fixed the testcase that Tobias posted in the subsequent correspondence. Bootstrapped and regtested on x86_64/FC17 - OK for trunk? Cheers Paul 2012-11-18 Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com> Paul Thomas <pault@gcc.gnu.org> PR fortran/46897 * gfortran.h : Add bit field 'defined_assign_comp' to symbol_attribute structure. Add primitive for gfc_add_full_array_ref. * expr.c (gfc_add_full_array_ref): New function. (gfc_lval_expr_from_sym): Call new function. * resolve.c (add_comp_ref): New function. (build_assignment): New function. (get_temp_from_expr): New function (add_code_to_chain): New function (generate_component_assignments): New function that calls all the above new functions. (resolve_code): Call generate_component_assignments. (check_defined_assignments): New function. (resolve_fl_derived0): Call check_defined_assignments. (gfc_resolve): Reset component_assignment_level in case it is left in a bad state by errors. * resolve.c (is_sym_host_assoc, resolve_procedure_interface, resolve_contained_fntype, resolve_procedure_expression, resolve_elemental_actual, resolve_global_procedure, is_scalar_expr_ptr, gfc_iso_c_func_interface, resolve_function, set_name_and_label, gfc_iso_c_sub_interface, resolve_specific_s0, resolve_operator, compare_bound_mpz_t, gfc_resolve_character_operator, resolve_typebound_function, gfc_resolve_expr, forall_index, remove_last_array_ref, conformable_arrays, resolve_allocate_expr, resolve_allocate_deallocate, resolve_select_type, resolve_transfer, resolve_where, gfc_resolve_where_code_in_forall, gfc_resolve_forall_body, gfc_count_forall_iterators, resolve_values, resolve_bind_c_comms, resolve_bind_c_derived_types, gfc_verify_binding_labels, apply_default_init, build_default_init_expr, apply_default_init_local, resolve_fl_var_and_proc, resolve_fl_procedure, gfc_resolve_finalizers, check_generic_tbp_ambiguity, resolve_typebound_intrinsic_op, resolve_typebound_procedure, resolve_typebound_procedures, ensure_not_abstract, resolve_fl_derived0, resolve_fl_parameter, resolve_symbol, resolve_equivalence_derived): Remove trailing white space. * gfortran.h : Remove trailing white space. 2012-01-18 Alessandro Fanfarillo <alessandro.fanfarillo@gmail.com> Paul Thomas <pault@gcc.gnu.org> PR fortran/46897 * gfortran.dg/defined_assignment_1.f90: New test. * gfortran.dg/defined_assignment_2.f90: New test. * gfortran.dg/defined_assignment_3.f90: New test. * gfortran.dg/defined_assignment_4.f90: New test. * gfortran.dg/defined_assignment_5.f90: New test. On 17 September 2012 20:45, Mikael Morin <mikael.morin@sfr.fr> wrote: > Hello, .... > And here comes the next round of comments. > .... >> + /* Add a full array ref, as necessary. */ >> + e->rank = c && c->as ? c->as->rank : 0; > This is bogus if e->rank was != 0 previously (think of the case > array(:)%scalar_comp). > The c == NULL case should be handled at the beginning (if at all). > >> + if (e->rank) > the condition should be on c->as (for the case array(:)%scalar_comp again). eliminated .... > all calls are with op == EXEC_ASSIGN, you may as well hardcode it. see comment - I was contemplating more general use of this code. .... >> + gcc_assert (e->expr_type == EXPR_VARIABLE >> + || e->expr_type == EXPR_FUNCTION); > As far as I know anything can be used, not only variables and functions. > The derived type cases are a bit specific but at least array/structure > constructors are missing. There could be also typebound function calls > (I never know whether they are EXPR_FUNCTION or something else). eliminated .... >> + ! Now do the defined assignments >> + do over components with typebound defined assignment [%cmp] >> + expr2%cmp {defined=} t1%cmp > I guess it should be `t1%cmp {defined=} expr2%cmp'? > >> + expr1%cmp = t1%cmp ! Store in the result >> + t1%cmp = t2%cmp ! Restore the original value > It seems to me that the last assignment isn't useful: once one component > has been taken care of, we proceed with the next one, so `t1' can have > garbage in the previous one without any impact. > Then if it can be removed, `t2' is useless and then `temp_x' as well, so > we could do with the simpler [still most of `t1' is useless]: > t1 = expr1 > expr1 = expr2 > t1%cmp {defined=} expr1%cmp > expr1%cmp = t1%cmp > > It would be nice too if the temporaries were avoided in the case there > is no defined assignment with intent(inout) lhs, but I leave the > decision to do it to you. > This has all been corrected. .... >> + || comp1->attr.pointer >> + || comp1->attr.allocatable >> + || comp1->attr.proc_pointer_comp > That one doesn't look right. It did not look right to me either - eliminating it causes a regression - I forget which test now. .... >> + gfc_free_statements (this_code); > `this_code' should be cleared, otherwise it is used in the next iteration. It's been nulled on each occasion. > > free (head); ? Done >> + sym->attr.defined_assign_comp >> + = super_type->attr.defined_assign_comp; > I guess Tobias' reported bug is here. The flag shouldn't be cleared > here if it was set just before. This was all put right. >> + >> /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that >> all DEFERRED bindings are overridden. */ >> if (super_type && super_type->attr.abstract && !sym->attr.abstract > > > To finish, I would like to draw your attention on the scalarizer not > supporting multiple arrays in the reference chain. The initial > expressions are guaranteed to have at most one array in the chain, but > as we add subfield references, that condition can not remain true. We > could try adding multiple references support in the scalarizer, but I > don't know how difficult it would be. Or maybe better fix it at the > front-end AST level by using elemental functions to split the > scalarization work. Or something else. What do you think? See the gfc_warning; If multiple array references are encountered, no attempt is made to use the defined assignments and the user is advised to make the (outer) loop explicit. With best regards Paul
Dear Paul, thanks for the updated patch. While reading your patch, I was wondering whether the attached test case works or not. Result: It does *not* print "Hello World" with neither gfortran nor crayftn. If one changes in "m3" the declared type of "x" from "t" to "t2", it shows "Hello World" with crayftn but still not with gfortran. I believe that it should show the message in both cases. I think the call should be done in the generated _copy function, which brings me to the point about: Paul Richard Thomas wrote: > Note that I have had to punt on defined assignments when there is more > than one part reference involved. The warning message suggests making > the loops explicit to make the defined assignment work. If I recall correctly, Mikael was wondering whether this should be handled by an elemental procedure. As _copy is an elemental procedure, it might be used. Tobias
Index: gcc/fortran/gfortran.h =================================================================== *** gcc/fortran/gfortran.h (revision 191115) --- gcc/fortran/gfortran.h (working copy) *************** typedef struct *** 786,794 **** /* The symbol is a derived type with allocatable components, pointer components or private components, procedure pointer components, possibly nested. zero_comp is true if the derived type has no ! component at all. */ unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1, ! private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1; /* This is a temporary selector for SELECT TYPE. */ unsigned select_type_temporary:1; --- 786,796 ---- /* The symbol is a derived type with allocatable components, pointer components or private components, procedure pointer components, possibly nested. zero_comp is true if the derived type has no ! component at all. defined_assign_comp is true if the derived ! type or an ancestor has a typebound defined assignment. */ unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1, ! private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1, ! defined_assign_comp:1; /* This is a temporary selector for SELECT TYPE. */ unsigned select_type_temporary:1; *************** gfc_try gfc_check_assign_symbol (gfc_sym *** 2761,2766 **** --- 2763,2769 ---- bool gfc_has_default_initializer (gfc_symbol *); gfc_expr *gfc_default_initializer (gfc_typespec *); gfc_expr *gfc_get_variable_expr (gfc_symtree *); + void gfc_add_full_array_ref (gfc_expr *, gfc_array_spec *); gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *); gfc_array_spec *gfc_get_full_arrayspec_from_expr (gfc_expr *expr); Index: gcc/fortran/expr.c =================================================================== *** gcc/fortran/expr.c (revision 191115) --- gcc/fortran/expr.c (working copy) *************** gfc_get_variable_expr (gfc_symtree *var) *** 3878,3883 **** --- 3878,3910 ---- } + /* Adds a full array reference to an expression, as needed. */ + + void + gfc_add_full_array_ref (gfc_expr *e, gfc_array_spec *as) + { + gfc_ref *ref; + for (ref = e->ref; ref; ref = ref->next) + if (!ref->next) + break; + if (ref) + { + ref->next = gfc_get_ref (); + ref = ref->next; + } + else + { + e->ref = gfc_get_ref (); + ref = e->ref; + } + ref->type = REF_ARRAY; + ref->u.ar.type = AR_FULL; + ref->u.ar.dimen = e->rank; + ref->u.ar.where = e->where; + ref->u.ar.as = as; + } + + gfc_expr * gfc_lval_expr_from_sym (gfc_symbol *sym) { *************** gfc_lval_expr_from_sym (gfc_symbol *sym) *** 3891,3906 **** /* It will always be a full array. */ lval->rank = sym->as ? sym->as->rank : 0; if (lval->rank) ! { ! lval->ref = gfc_get_ref (); ! lval->ref->type = REF_ARRAY; ! lval->ref->u.ar.type = AR_FULL; ! lval->ref->u.ar.dimen = lval->rank; ! lval->ref->u.ar.where = sym->declared_at; ! lval->ref->u.ar.as = sym->ts.type == BT_CLASS ! ? CLASS_DATA (sym)->as : sym->as; ! } ! return lval; } --- 3918,3925 ---- /* It will always be a full array. */ lval->rank = sym->as ? sym->as->rank : 0; if (lval->rank) ! gfc_add_full_array_ref (lval, sym->ts.type == BT_CLASS ? ! CLASS_DATA (sym)->as : sym->as); return lval; } Index: gcc/fortran/resolve.c =================================================================== *** gcc/fortran/resolve.c (revision 191115) --- gcc/fortran/resolve.c (working copy) *************** resolve_ordinary_assign (gfc_code *code, *** 9516,9521 **** --- 9516,9791 ---- } + /* Add a component reference onto an expression. */ + + static void + add_comp_ref (gfc_expr *e, gfc_component *c) + { + gfc_ref **ref; + ref = &(e->ref); + while (*ref) + ref = &((*ref)->next); + *ref = gfc_get_ref(); + (*ref)->type = REF_COMPONENT; + (*ref)->u.c.sym = e->ts.u.derived; + (*ref)->u.c.component = c; + e->ts = c->ts; + + /* Add a full array ref, as necessary. */ + e->rank = c && c->as ? c->as->rank : 0; + if (e->rank) + gfc_add_full_array_ref (e, c->as); + } + + + /* Build an assignment. */ + + static gfc_code * + build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2, + gfc_component *comp1, gfc_component *comp2, locus loc) + { + gfc_code *this_code; + + this_code = gfc_get_code (); + this_code->op = op; + this_code->next = NULL; + this_code->expr1 = gfc_copy_expr (expr1); + this_code->expr2 = gfc_copy_expr (expr2); + this_code->loc = loc; + if (comp1 && comp2) + { + add_comp_ref (this_code->expr1, comp1); + add_comp_ref (this_code->expr2, comp2); + } + + return this_code; + } + + + /* Makes a temporary variable expression based on the characteristics of + a given expression. */ + + static gfc_expr* + get_temp_from_expr (gfc_expr *e, gfc_namespace *ns) + { + static int serial = 0; + char name[GFC_MAX_SYMBOL_LEN]; + gfc_symtree *tmp; + gfc_ref *ref = NULL, *eref; + + gcc_assert (e->expr_type == EXPR_VARIABLE + || e->expr_type == EXPR_FUNCTION); + sprintf (name, "da@%d", serial++); + gfc_get_sym_tree (name, ns, &tmp, false); + gfc_add_type (tmp->n.sym, &e->ts, NULL); + + for (eref = e->ref; eref; eref = eref->next) + if (eref->type == REF_COMPONENT) + ref = eref; + + if (!ref) + { + tmp->n.sym->attr = e->symtree->n.sym->attr; + if (e->symtree->n.sym->as) + tmp->n.sym->as + = gfc_copy_array_spec (e->symtree->n.sym->as); + } + else + { + tmp->n.sym->attr = ref->u.c.component->attr; + if (ref->u.c.component->as) + tmp->n.sym->as + = gfc_copy_array_spec (ref->u.c.component->as); + } + + gfc_set_sym_referenced (tmp->n.sym); + gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); + return gfc_lval_expr_from_sym (tmp->n.sym); + } + + + /* Add one line of code to the code chain, making sure that 'head' and + 'tail' are appropriately updated. */ + + static void + add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail) + { + gcc_assert (this_code); + if (*head == NULL) + *head = *tail = *this_code; + else + *tail = gfc_append_code (*tail, *this_code); + *this_code = NULL; + } + + + /* Implement 7.2.1.3 of the F08 standard: + "An intrinsic assignment where the variable is of derived type is + performed as if each component of the variable were assigned from the + corresponding component of expr using pointer assignment (7.2.2) for + each pointer component, defined assignment for each nonpointer + nonallocatable component of a type that has a type-bound defined + assignment consistent with the component, intrinsic assignment for + each other nonpointer nonallocatable component, ..." + + The pointer assignments are taken care of by the intrinsic + assignment of the structure itself. This function recursively adds + defined assignments where required. + + Since the lhs in a defined assignment can have intent INOUT, the code + to do this gets a bit messy. In pseudo-code: + + ! Only call function lhs once. + if (lhs is a function) + temp_x = expr2 + expr2 = expr(temp_x) + ! Need two temporaries for lhs. + t1 = expr1 + t2 = expr2 + ! Do the intrinsic assignment + expr1 = expr2 + ! Now do the defined assignments + do over components with typebound defined assignment [%cmp] + expr2%cmp {defined=} t1%cmp + expr1%cmp = t1%cmp ! Store in the result + t1%cmp = t2%cmp ! Restore the original value + */ + + static void + generate_component_assignments (gfc_code **code, gfc_namespace *ns) + { + gfc_component *comp1, *comp2; + gfc_code *this_code = NULL, *head = NULL, *tail = NULL; + gfc_expr *t1, *t2; + + /* Filter out continuing processing after an error. */ + if ((*code)->expr1->ts.type != BT_DERIVED + || (*code)->expr2->ts.type != BT_DERIVED) + return; + + /* Create a temporary so that functions get called once. */ + if ((*code)->expr2->expr_type != EXPR_VARIABLE) + { + gfc_expr *tmp_expr; + + /* Assign the rhs to the temporary. */ + tmp_expr = get_temp_from_expr ((*code)->expr1, ns); + this_code = build_assignment (EXEC_ASSIGN, + tmp_expr, (*code)->expr2, + NULL, NULL, (*code)->loc); + + /* Add the code and substitute the rhs expression. */ + add_code_to_chain (&this_code, &head, &tail); + gfc_free_expr ((*code)->expr2); + (*code)->expr2 = tmp_expr; + } + + /* Build the two temporaries required for the assignment. */ + t1 = get_temp_from_expr ((*code)->expr1, ns); + this_code = build_assignment (EXEC_ASSIGN, + t1, (*code)->expr1, + NULL, NULL, (*code)->loc); + add_code_to_chain (&this_code, &head, &tail); + t2 = get_temp_from_expr ((*code)->expr1, ns); + this_code = build_assignment (EXEC_ASSIGN, + t2, (*code)->expr1, + NULL, NULL, (*code)->loc); + add_code_to_chain (&this_code, &head, &tail); + + /* Do the intrinsic assignment. This is not needed if the lhs is one + of the temporaries generated here, since the intrinsic assignment + to the final result already does this. */ + if ((*code)->expr1->symtree->n.sym->name[2] != '@') + { + this_code = build_assignment (EXEC_ASSIGN, + (*code)->expr1, (*code)->expr2, + NULL, NULL, (*code)->loc); + add_code_to_chain (&this_code, &head, &tail); + } + + comp1 = (*code)->expr1->ts.u.derived->components; + comp2 = (*code)->expr2->ts.u.derived->components; + + for (; comp1; comp1 = comp1->next, comp2 = comp2->next) + { + /* The intrinsic assignment does the right thing for pointers + of all kinds and allocatable components. */ + if (comp1->ts.type != BT_DERIVED + || comp1->attr.pointer + || comp1->attr.allocatable + || comp1->attr.proc_pointer_comp + || comp1->attr.class_pointer + || comp1->attr.proc_pointer) + continue; + + if (this_code) + add_code_to_chain (&this_code, &head, &tail); + + /* Make an assigment for this component. */ + this_code = gfc_get_code (); + this_code = build_assignment (EXEC_ASSIGN, + t1, (*code)->expr2, + comp1, comp2, (*code)->loc); + + /* Convert the assignment if there is a defined assignment for + this type. Otherwise, using the call from resolve_code, + recurse into its components. */ + resolve_code (this_code, ns); + + if (this_code->op == EXEC_ASSIGN_CALL) + { + /* Check that there is a typebound defined assignment. If not, + then this must be a module defined assignment. We cannot + use the defined_assign_comp attribute here because it must + be this derived type that has the defined assignment and not + a parent type. */ + if (!(comp1->ts.u.derived->f2k_derived + && comp1->ts.u.derived->f2k_derived + ->tb_op[INTRINSIC_ASSIGN])) + { + gfc_free_statements (this_code); + continue; + } + } + else if (this_code->op == EXEC_ASSIGN && !this_code->next) + { + /* Don't add intrinsic assignments since they are already + effected by the intrinsic assignment of the structure. */ + gfc_free_statements (this_code); + continue; + } + + add_code_to_chain (&this_code, &head, &tail); + + /* Transfer the value to the final result. */ + this_code = build_assignment (EXEC_ASSIGN, + (*code)->expr1, t1, + comp1, comp2, (*code)->loc); + add_code_to_chain (&this_code, &head, &tail); + + /* Restore the value of t1. This code is added to the chain at + the start of the loop if more defined assignments. */ + this_code = build_assignment (EXEC_ASSIGN, + t1, t2, + comp1, comp2, (*code)->loc); + } + + if (this_code) + gfc_free_statements (this_code); + + /* Now attach the remaining code chain to the input code. Step on + to the end of the new code since resolution is complete. */ + gcc_assert ((*code)->op == EXEC_ASSIGN); + tail->next = (*code)->next; + /* Overwrite 'code' because this would place the intrinsic assignment + before the temporary for the lhs is created. */ + gfc_free_expr ((*code)->expr1); + gfc_free_expr ((*code)->expr2); + **code = *head; + *code = tail; + } + + /* Given a block of code, recursively resolve everything pointed to by this code block. */ *************** resolve_code (gfc_code *code, gfc_namesp *** 9678,9683 **** --- 9948,9959 ---- else goto call; } + + /* F03 7.4.1.3 for non-allocatable, non-pointer components. */ + if (code->expr1->ts.type == BT_DERIVED + && code->expr1->ts.u.derived->attr.defined_assign_comp) + generate_component_assignments (&code, ns); + break; case EXEC_LABEL_ASSIGN: *************** resolve_fl_derived0 (gfc_symbol *sym) *** 12282,12289 **** --- 12558,12574 ---- || c->attr.proc_pointer || c->attr.allocatable)) == FAILURE) return FAILURE; + + if (c->ts.type == BT_DERIVED + && c->ts.u.derived->f2k_derived + && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]) + sym->attr.defined_assign_comp = 1; } + if (super_type) + sym->attr.defined_assign_comp + = super_type->attr.defined_assign_comp; + /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that all DEFERRED bindings are overridden. */ if (super_type && super_type->attr.abstract && !sym->attr.abstract Index: gcc/testsuite/gfortran.dg/defined_assignment_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/defined_assignment_1.f90 (revision 0) --- gcc/testsuite/gfortran.dg/defined_assignment_1.f90 (revision 0) *************** *** 0 **** --- 1,90 ---- + ! { dg-do run } + ! Test the fix for PR46897. + ! + ! Contributed by Rouson Damian <rouson@sandia.gov> + ! + module m0 + implicit none + type component + integer :: i = 0 + contains + procedure :: assign0 + generic :: assignment(=)=>assign0 + end type + type parent + type(component) :: foo + end type + type, extends(parent) :: child + integer :: j + end type + contains + subroutine assign0(lhs,rhs) + class(component), intent(out) :: lhs + class(component), intent(in) :: rhs + lhs%i = 20 + end subroutine + type(child) function new_child() + end function + end module + + module m1 + implicit none + type component1 + integer :: i = 1 + contains + procedure :: assign1 + generic :: assignment(=)=>assign1 + end type + type t + type(component1) :: foo + end type + contains + subroutine assign1(lhs,rhs) + class(component1), intent(out) :: lhs + class(component1), intent(in) :: rhs + lhs%i = 21 + end subroutine + end module + + module m2 + implicit none + type component2 + integer :: i = 2 + end type + interface assignment(=) + module procedure assign2 + end interface + type t2 + type(component2) :: foo + end type + contains + subroutine assign2(lhs,rhs) + type(component2), intent(out) :: lhs + type(component2), intent(in) :: rhs + lhs%i = 22 + end subroutine + end module + + program main + use m0 + use m1 + use m2 + implicit none + type(child) :: infant0 + type(t) :: infant1, newchild1 + type(t2) :: infant2, newchild2 + + ! Test the reported problem. + infant0 = new_child() + if (infant0%parent%foo%i .ne. 20) call abort + + ! Test the case of comment #1 of the PR. + infant1 = newchild1 + if (infant1%foo%i .ne. 21) call abort + + ! Test the case of comment #2 of the PR. + infant2 = newchild2 + if (infant2%foo%i .ne. 2) call abort + end + + Index: gcc/testsuite/gfortran.dg/defined_assignment_2.f90 =================================================================== *** gcc/testsuite/gfortran.dg/defined_assignment_2.f90 (revision 0) --- gcc/testsuite/gfortran.dg/defined_assignment_2.f90 (revision 0) *************** *** 0 **** --- 1,74 ---- + ! { dg-do run } + ! Test the fix for PR46897. defined_assignment_1.f90 checks that the PR + ! testcases run correctly, this checks that other requirements of the + ! standard are satisfied. + ! + module m0 + implicit none + type component + integer :: i = 0 + integer, allocatable :: j(:) + contains + procedure :: assign0 + generic :: assignment(=)=>assign0 + end type + type parent + type(component) :: foo1 + end type + type, extends(parent) :: child + integer :: k = 1000 + integer, allocatable :: l(:) + type(component) :: foo2 + end type + contains + subroutine assign0(lhs,rhs) + class(component), intent(inout) :: lhs + class(component), intent(in) :: rhs + if (lhs%i .eq. 0) then + lhs%i = rhs%i + lhs%j = rhs%j + else + lhs%i = rhs%i*2 + lhs%j = [rhs%j, rhs%j*2] + end if + end subroutine + type(child) function new_child() + new_child%parent%foo1%i = 20 + new_child%foo2%i = 21 + new_child%parent%foo1%j = [99,199] + new_child%foo2%j = [199,299] + new_child%l = [299,399] + new_child%k = 1001 + end function + end module + + program main + use m0 + implicit none + type(child) :: infant0 + + ! Check that the INTENT(INOUT) of assign0 is respected and that the + ! correct thing is done with allocatable components. + infant0 = new_child() + if (infant0%parent%foo1%i .ne. 20) call abort + if (infant0%foo2%i .ne. 21) call abort + if (any (infant0%parent%foo1%j .ne. [99,199])) call abort + if (any (infant0%foo2%j .ne. [199,299])) call abort + if (infant0%foo2%i .ne. 21) call abort + if (any (infant0%l .ne. [299,399])) call abort + + ! Now, since the defined assignment depends on whether or not the 'i' + ! component is the default initialization value, the result will be + ! different. + infant0 = new_child() + if (infant0%parent%foo1%i .ne. 40) call abort + if (any (infant0%parent%foo1%j .ne. [99,199,198,398])) call abort + if (any (infant0%foo2%j .ne. [199,299,398,598])) call abort + if (infant0%foo2%i .ne. 42) call abort + if (any (infant0%l .ne. [299,399])) call abort + + ! Finally, make sure that normal components of the declared type survive. + if (infant0%k .ne. 1001) call abort + end + + Index: gcc/testsuite/gfortran.dg/defined_assignment_3.f90 =================================================================== *** gcc/testsuite/gfortran.dg/defined_assignment_3.f90 (revision 0) --- gcc/testsuite/gfortran.dg/defined_assignment_3.f90 (revision 0) *************** *** 0 **** --- 1,38 ---- + ! { dg-do run } + ! Test the fix for PR46897. defined_assignment_1.f90 checks that the PR + ! testcases run correctly, this checks array components work correctly. + ! + module m0 + implicit none + type component + integer :: i = 0 + contains + procedure :: assign0 + generic :: assignment(=)=>assign0 + end type + type parent + type(component) :: foo(2) + end type + type, extends(parent) :: child + integer :: j + end type + contains + elemental subroutine assign0(lhs,rhs) + class(component), intent(out) :: lhs + class(component), intent(in) :: rhs + lhs%i = 20 + end subroutine + end module + + + program main + use m0 + implicit none + type(child) :: infant0 + + infant0 = child([component(1),component(2)], 99) + if (any (infant0%parent%foo%i .ne. [20, 20])) call abort + + end + +