| Message ID | CAGkQGiLUJSqmV-CdnbiK=iVMsfgP62a3X28kDsCsXUDjPTNa3A@mail.gmail.com |
|---|---|
| State | New |
| Headers | show |
Hello Paul, I think there are a couple of bugs not triggered by the single component types in the test. See below. On 13/08/2012 15:37, Paul Richard Thomas wrote: > + > + /* Go through the code chain eliminating all but calls to > + typebound procedures. Since we have been through > + resolve_typebound_subroutine. */ > + for (; this_code; this_code = this_code->next) > + { > + if (this_code->op == EXEC_ASSIGN_CALL) > + { > + gfc_symbol *fsym = this_code->symtree->n.sym->formal->sym; > + /* Check that there is a defined assignment. If so, then > + resolve the call. */ > + if (fsym->ts.type == BT_CLASS > + && CLASS_DATA (fsym)->ts.u.derived->f2k_derived > + && CLASS_DATA (fsym)->ts.u.derived->f2k_derived > + ->tb_op[INTRINSIC_ASSIGN]) > + { > + resolve_call (this_code); > + goto next; > + } > + } > + > + next = this_code->next; > + if (this_code == root) > + root = next; > + else > + previous->next = next; > + > + next = this_code; > + next->next = NULL; > + gfc_free_statements (next); This frees `this_code', but `this_code' is used to iterate the loop and below. > + next: > + previous = this_code; This could be moved to the only next caller (`previous' doesn't need to be updated if `this_code' is removed) to fix one usage of `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. */ This tells me that you know what you do... > + if (root) > + { > + next = (*code)->next; > + (*code)->next = root; > + for (;root; root = root->next) > + if (!root->next) > + break; > + root->next = next; > + *code = root; > + } ... but I have the feeling that this makes (*code) unreachable and that that's wrong. Shouldn't it be "root->next = *code;" ? Maybe you want to remove (*code) at the first iteration (as it contains the whole structure assignment), but in the next iteration, it contains the first typebound call, etc, doesn't it? By the way I'm not sure we can keep the whole structure assignment to handle default assignment: if we do it after the typebound calls, we overwrite their job so we have to do it before. However, if we do it before, we also overwrite components to be assigned with a typebound call, and this can have some side effects as the LHS's argument can be INTENT(INOUT). Thoughts? Mikael
Dear Mikael, > I think there are a couple of bugs not triggered by the single component > types in the test. See below. Yes, you are right. We should have tested multiple components... my fault! > This could be moved to the only next caller (`previous' doesn't need to > be updated if `this_code' is removed) to fix one usage of `this_code' :-). That's right... I'll make it so. > ... but I have the feeling that this makes (*code) unreachable and that > that's wrong. Shouldn't it be "root->next = *code;" ? No. That caused the regression that I mentioned. (*code) is resolved, at entry. resolve_code steps on to (*code)->next. > if we do it after the typebound calls, we overwrite their job so we have > to do it before. This is what is done. > However, if we do it before, we also overwrite components to be assigned > with a typebound call, and this can have some side effects as the LHS's > argument can be INTENT(INOUT). This might be so but it is what the standard dictates should happen.... isn't it? Thanks for the review. I believe, in summary, that I should handle 'this_code' consistently so that multiple component defined assignments work correctly. I should also verify that pointers do what they are supposed to do, although it is rather trivial. Cheers Paul
Dear Paul, Dear all, I tried to compile the check_compiler_for_memory_leaks.F90 file provided by Damian and it produces a segfault error. May be the problem is related with add_comp_ref. Regards Alessandro (from Malta) 2012/8/14 Paul Richard Thomas <paul.richard.thomas@gmail.com> > > Dear Mikael, > > > I think there are a couple of bugs not triggered by the single component > > types in the test. See below. > > Yes, you are right. We should have tested multiple components... my > fault! > > > This could be moved to the only next caller (`previous' doesn't need to > > be updated if `this_code' is removed) to fix one usage of `this_code' > > :-). > > That's right... I'll make it so. > > > ... but I have the feeling that this makes (*code) unreachable and that > > that's wrong. Shouldn't it be "root->next = *code;" ? > > No. That caused the regression that I mentioned. (*code) is > resolved, at entry. resolve_code steps on to (*code)->next. > > > if we do it after the typebound calls, we overwrite their job so we have > > to do it before. > > This is what is done. > > > However, if we do it before, we also overwrite components to be assigned > > with a typebound call, and this can have some side effects as the LHS's > > argument can be INTENT(INOUT). > > This might be so but it is what the standard dictates should > happen.... isn't it? > > Thanks for the review. I believe, in summary, that I should handle > 'this_code' consistently so that multiple component defined > assignments work correctly. I should also verify that pointers do > what they are supposed to do, although it is rather trivial. > > Cheers > > Paul -- Dott. Alessandro Fanfarillo Verificatore Ellisse Cell: 339/2428012 Email: alessandro.fanfarillo@gmail.com
On 14/08/2012 07:03, Paul Richard Thomas wrote: >> However, if we do it before, we also overwrite components to be assigned >> with a typebound call, and this can have some side effects as the LHS's >> argument can be INTENT(INOUT). > > This might be so but it is what the standard dictates should > happen.... isn't it? > It dictates that the components should be assigned one by one (by either defined or intrinsic assignment), which I don't see as strictly equivalent to a whole structure assignment followed by typebound calls (for components needing it). Mikael
On 14/08/2012 07:03, Paul Richard Thomas wrote: >> ... but I have the feeling that this makes (*code) unreachable and that >> that's wrong. Shouldn't it be "root->next = *code;" ? > > No. That caused the regression that I mentioned. (*code) is > resolved, at entry. resolve_code steps on to (*code)->next. > Yes, OK. Double pointers are really on the limits of my spirit. Mikael
Index: gcc/fortran/resolve.c =================================================================== *** gcc/fortran/resolve.c (revision 190338) --- gcc/fortran/resolve.c (working copy) *************** resolve_ordinary_assign (gfc_code *code, *** 9485,9490 **** --- 9485,9614 ---- } + /* 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 = c->ts.u.derived; + (*ref)->u.c.component = c; + e->ts = c->ts; + } + + + /* 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. */ + + static void + generate_component_assignments (gfc_code **code, gfc_namespace *ns) + { + gfc_component *comp1, *comp2; + gfc_code *this_code, *next, *root, *previous; + + /* Filter out continuing processing after an error. */ + if ((*code)->expr1->ts.type != BT_DERIVED + || (*code)->expr2->ts.type != BT_DERIVED) + return; + + comp1 = (*code)->expr1->ts.u.derived->components; + comp2 = (*code)->expr2->ts.u.derived->components; + + for (; comp1; comp1 = comp1->next, comp2 = comp2->next) + { + if (comp1->ts.type != BT_DERIVED + || comp1->ts.u.derived == NULL + || (comp1->attr.pointer || comp1->attr.allocatable) + || (*code)->expr1->ts.u.derived == comp1->ts.u.derived) + continue; + + /* Make an assigment for this component. */ + this_code = gfc_get_code (); + this_code->op = EXEC_ASSIGN; + this_code->next = NULL; + this_code->expr1 = gfc_copy_expr ((*code)->expr1); + this_code->expr2 = gfc_copy_expr ((*code)->expr2); + + add_comp_ref (this_code->expr1, comp1); + add_comp_ref (this_code->expr2, comp2); + + root = this_code; + + /* Convert the assignment if there is a defined assignment for + this type. Otherwise, recurse into its components. */ + if (resolve_ordinary_assign (this_code, ns) + && this_code->op == EXEC_COMPCALL) + resolve_typebound_subroutine (this_code); + else if (this_code && this_code->op == EXEC_ASSIGN) + generate_component_assignments (&this_code, ns); + + previous = NULL; + this_code = root; + + /* Go through the code chain eliminating all but calls to + typebound procedures. Since we have been through + resolve_typebound_subroutine. */ + for (; this_code; this_code = this_code->next) + { + if (this_code->op == EXEC_ASSIGN_CALL) + { + gfc_symbol *fsym = this_code->symtree->n.sym->formal->sym; + /* Check that there is a defined assignment. If so, then + resolve the call. */ + if (fsym->ts.type == BT_CLASS + && CLASS_DATA (fsym)->ts.u.derived->f2k_derived + && CLASS_DATA (fsym)->ts.u.derived->f2k_derived + ->tb_op[INTRINSIC_ASSIGN]) + { + resolve_call (this_code); + goto next; + } + } + + next = this_code->next; + if (this_code == root) + root = next; + else + previous->next = next; + + next = this_code; + next->next = NULL; + gfc_free_statements (next); + next: + previous = 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. */ + if (root) + { + next = (*code)->next; + (*code)->next = root; + for (;root; root = root->next) + if (!root->next) + break; + root->next = next; + *code = root; + } + } + } + + /* Given a block of code, recursively resolve everything pointed to by this code block. */ *************** resolve_code (gfc_code *code, gfc_namesp *** 9647,9652 **** --- 9771,9781 ---- else goto call; } + + /* F03 7.4.1.3 for non-allocatable, non-pointer components. */ + if (code->expr1->ts.type == BT_DERIVED) + generate_component_assignments (&code, ns); + break; case EXEC_LABEL_ASSIGN: 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 + 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 component + integer :: i + contains + procedure :: assign1 + generic :: assignment(=)=>assign1 + end type + type t + type(component) :: foo + end type + contains + subroutine assign1(lhs,rhs) + class(component), intent(out) :: lhs + class(component), 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 + +