Re: [Patch, fortran] PR46897 - [OOP] type-bound defined ASSIGNMENT(=) not used for derived type component in intrinsic assign

[Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>]

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.
 The resulting code can be quite profligate:

  infant0 = new_child()

produces

  ASSIGN main:da@0 new_child[[()]]
  ASSIGN main:da@1 main:infant0
  ASSIGN main:da@2 main:infant0
  ASSIGN main:infant0 main:da@0
  ASSIGN main:da@3 main:da@1 % parent
  ASSIGN main:da@4 main:da@1 % parent
  CALL assign0 ((main:da@3 % foo) (main:da@0 % parent % foo))
  ASSIGN main:da@1 % parent % foo main:da@3 % foo
  ASSIGN main:infant0 % parent main:da@1 % parent

It could be simplified, I suspect but I do not believe that it is
worth any more effort for what is, after all, well off the beaten
track.

The comments in resolve.c explain how the patch works.

Bootstrapped and regtested on FC9/x86_64 - OK for trunk?

Cheers

Paul

2012-09-10   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.

2012-09-10   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.



On 14/08/2012, Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:
> Mikael,
>
> On 14 August 2012 10:42, Mikael Morin <mikael.morin@sfr.fr> wrote:
>> 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).
>
> Hmmm.  That's true.  ***sigh***
>
> I'll put it right.
>
> Cheers
>
> Paul
>

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
+ 
+