Dear All,
Please find attached a patch and testcase for the above PR. The
comment before generate_component_assignments explains the need for
the patch, which itself is fairly self explanatory.
Bootstrapped and regtested on Fc9/x86_64 - OK for trunk?
Best regards
Paul and Alessandro.
2012-08-13 Alessandro Fanfarillo <alessandro.fanfari...@gmail.com>
Paul Thomas <pa...@gcc.gnu.org>
PR fortran/46897
* resolve.c (add_comp_ref): New function.
(generate_component_assignments): New function that calls
add_comp_ref.
(resolve_code): Call generate_component_assignments.
2012-08-13 Alessandro Fanfarillo <alessandro.fanfari...@gmail.com>
Paul Thomas <pa...@gcc.gnu.org>
PR fortran/46897
* gfortran.dg/defined_assignment_1.f90: New test.
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 <rou...@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
+
+
