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, deﬁned assignment for each nonpointer
+    nonallocatable component of a type that has a type-bound deﬁned
+    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
+ 
+ 
