diff mbox

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

Message ID 50B25D25.7060401@sfr.fr
State New
Headers show

Commit Message

Mikael Morin Nov. 25, 2012, 6:02 p.m. UTC 
Hello Paul,

Le 18/11/2012 18:09, Paul Richard Thomas a écrit :
> 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.
thanks for your continued work despite that.

>
> 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 prefer not having the whitespace changes, or at least having them in a 
separate commit, so I have reviewed the patch without them (attached 
file).  It was just a matter of applying the patch and using `svn -x -w 
diff' to get the clean version.

>
> 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 :-(
Tobias proved you wrong already ;-), but otherwise it looks complete as 
far as I'm concerned.

Regarding Tobias' bug, the tests provided show the patch working in the 
common cases, and some less common ones. So, with the release schedule 
in mind, I propose we don't delay further the patch getting broad 
testing on the trunk. If release managers and other fortran maintainers 
agree of course.

Some nits are pointed out below.
Thanks for the patch.

Mikael


> diff --git a/gfortran.h b/gfortran.h
> index fabc16a..3bcffe9 100644
> --- a/gfortran.h
> +++ b/gfortran.h
> @@ -786,9 +786,11 @@ typedef struct
>    /* 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.  */
> +     component at all.  defined_assign_comp is true if the derived
> +     type or an ancestor has a typebound defined assignment.  */
I'm not sure what you mean by ancestor. I suggest rather something like:
defined_assign_comp is true if the derived type or a (sub-)component has 
a typebound defined assignment.



> diff --git a/resolve.c b/resolve.c
> index 53d695c..43ac38c 100644
> --- a/resolve.c
> +++ b/resolve.c
> +
> +
> +/* 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_array_spec *as;
> +  gfc_array_ref *aref;
> +  gfc_ref *ref;
> +
> +  sprintf (name, "DA@%d", serial++);
> +  gfc_get_sym_tree (name, ns, &tmp, false);
> +  gfc_add_type (tmp->n.sym, &e->ts, NULL);
> +
> +  as = NULL;
> +  ref = NULL;
> +  aref = NULL;
> +
> +  /* Obtain the arrayspec for the temporary.  */
> +  if (e->rank)
> +    {
> +      aref = gfc_find_array_ref (e);
> +      if (e->expr_type == EXPR_VARIABLE
> +	  && e->symtree->n.sym->as == aref->as)
> +	as = aref->as;
> +      else
> +	{
> +	  for (ref = e->ref; ref; ref = ref->next)
> +	    if (ref->type == REF_COMPONENT
> +		&& ref->u.c.component->as == aref->as)
> +	      {
> +		as = aref->as;
> +		break;
> +	      }
> +	  }
indent error.

It seems that only EXPR_VARIABLE is supported here (It's OK as long as 
the function is only called with e == lhs). You should either make it 
explicit with an assertion or a comment, or add support for EXPR_OP, 
EXPR_FUNCTION, EXPR_ARRAY, etc.

> +    }
> +
> +  /* Add the attributes and the arrayspec to the temporary.  */
> +  tmp->n.sym->attr = gfc_expr_attr (e);
> +  if (as)
> +    {
> +      tmp->n.sym->as = gfc_copy_array_spec (as);
> +      if (!ref)
> +	ref = e->ref;
> +      if (as->type == AS_DEFERRED)
> +	tmp->n.sym->attr.allocatable = 1;
> +    }
> +  else
> +    tmp->n.sym->attr.dimension = 0;
> +
> +  gfc_set_sym_referenced (tmp->n.sym);
> +  gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
> +  e = gfc_lval_expr_from_sym (tmp->n.sym);
> +
> +  /* Should the lhs be a section, use its array ref for the
> +     temporary expression.  */
> +  if (aref && aref->type != AR_FULL)
> +    {
> +      gfc_free_ref_list (e->ref);
> +      e->ref = gfc_copy_ref (ref);
copy _before_ freeing.

> +    }
> +  return e;
> +}


> +/* Counts the potential number of part array references that would
> +   result from resolution of typebound defined assignments.  */
> +
> +static int
> +nonscalar_typebound_assign (gfc_symbol *derived, int depth)
> +{
> +  gfc_component *c;
> +  int c_depth = 0, t_depth;
> +
> +  for (c= derived->components; c; c = c->next)
> +    {
> +      if ((c->ts.type != BT_DERIVED
> +	  || c->attr.pointer
> +	  || c->attr.allocatable
> +	  || c->attr.proc_pointer_comp
> +	  || c->attr.class_pointer
> +	  || c->attr.proc_pointer)
> +	  && !c->attr.defined_assign_comp)
indent || and && differently.

[...]
> +   When the lhs in a defined assignment has intent INOUT, we need a
> +   temporary for the lhs.  In pseudo-code:
> +
> +   ! Only call function lhs once.
> +      if (lhs is not a constant or an variable)
> +	  temp_x = expr2
> +          expr2 => temp_x
> +   ! Do the intrinsic assignment
> +      expr1 = expr2
> +   ! Now do the defined assignments
> +      do over components with typebound defined assignment [%cmp]
> +        if (arg1 of defined assignment procedure is INOUT)
> +	    t1%cmp {defined=} expr2%cmp  ! ensures INOUT lhs uses value
> +					 ! unaffected by intrinsic assign
> +	    expr1%cmp = t1%cmp           ! Store in the result
> +	else
> +	    expr1%cmp {defined=} expr2%cmp
This is a bit confusing: the ifs are not part of the generated code, and 
the assignment to t1 is missing. I suggest the following, but it's a 
minor nit anyway.

#if one component's assignment procedure is INOUT

       t1 = expr1

   # if expr2 non-variable
       temp_x = expr2
       expr2 => temp_x
   # endif

       expr1 = expr2

   # for each cmp
       t1%cmp {defined=} expr2%cmp
       expr1%cmp = t1%cmp

#else

       expr1 = expr2

   # for each cmp
       expr1%cmp {defined=} expr2%cmp

#endif

> +
> +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;
> +  int error_count, depth;
> +/*  gfc_array_ref *aref;*/
Can be removed. ;-)

> +
> +  gfc_get_errors (NULL, &error_count);
> +
> +  /* Filter out continuing processing after an error.  */
> +  if (error_count
> +      || (*code)->expr1->ts.type != BT_DERIVED
> +      || (*code)->expr2->ts.type != BT_DERIVED)
> +    return;
> +
> +  /* TODO: Handle more than one part array reference in assignments.  */
> +  depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
> +				      (*code)->expr1->rank ? 1 : 0);
> +  if (depth > 1)
> +    {
> +      gfc_warning ("TODO: type-bound defined assignment(s) at %L not "
> +		   "done because multiple part array references would "
> +		   "occur in intermediate expressions.", &(*code)->loc);
> +      return;
> +    }
> +
> +  component_assignment_level++;
> +
> +  /* Create a temporary so that functions get called only once.  */
> +  if ((*code)->expr2->expr_type != EXPR_VARIABLE
> +      && (*code)->expr2->expr_type != EXPR_CONSTANT)
> +    {
> +      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, &tmp_head, &tmp_tail);
> +      gfc_free_expr ((*code)->expr2);
> +      (*code)->expr2 = tmp_expr;
> +    }
> +
> +  /* 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;
> +
> +  t1 = NULL;
> +  for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
> +    {
> +      bool inout = false;
> +
> +      /* 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);
This doesn't seem to be necessary anymore, as this_code is cleared in 
all paths leading to this.

> +
> +      /* Make an assigment for this component.  */
> +      this_code = gfc_get_code ();
> +      this_code = build_assignment (EXEC_ASSIGN,
> +				    (*code)->expr1, (*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)
> +	{
> +	  gfc_symbol *rsym;
> +	  /* 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
Use tab in indent.

> +					->tb_op[INTRINSIC_ASSIGN]))
> +	    {
> +	      gfc_free_statements (this_code);
this_code = NULL;

> +	      continue;
> +	    }
> +
> +	  /* If the first argument of the subroutine has intent INOUT
> +	     a temporary must be generated and used instead.  */
> +	  rsym = this_code->resolved_sym;
> +	  if (rsym->formal
> +	      && rsym->formal->sym->attr.intent == INTENT_INOUT)
> +	    {
> +	      gfc_code *temp_code;
> +	      inout = true;
> +
> +	      /* Build the temporary required for the assignment and put
> +		 it at the head of the generated code.  */
> +	      if (!t1)
> +		{
> +		  t1 = get_temp_from_expr ((*code)->expr1, ns);
> +		  temp_code = build_assignment (EXEC_ASSIGN,
> +						t1, (*code)->expr1,
> +				NULL, NULL, (*code)->loc);
> +	          add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
Use tab in indent.

> +		}
> +
> +	      /* Replace the first actual arg with the component of the
> +		 temporary.  */
> +	      gfc_free_expr (this_code->ext.actual->expr);
> +	      this_code->ext.actual->expr = gfc_copy_expr (t1);
> +	      add_comp_ref (this_code->ext.actual->expr, comp1);
> +	    }
> +	  }
> +      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);
> +	  this_code = NULL;
> +	  continue;
> +	}
> +
> +      add_code_to_chain (&this_code, &head, &tail);
> +
> +      if (t1 && inout)
> +	{
> +	  /* 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);
> +	}
> +    }
> +
> +  if (this_code)
this_code seems to be NULL at this point.

> +    {
> +      gfc_free_statements (this_code);
> +      this_code = NULL;
> +    }
> +
> +  /* Put the temporary assignments at the top of the generated code.  */
> +  if (tmp_head && component_assignment_level == 1)
> +    {
> +      gfc_append_code (tmp_head, head);
> +      head = tmp_head;
> +      tmp_head = tmp_tail = NULL;
> +    }
> +
> +  /* 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;
> +
> +  component_assignment_level--;
> +}
> +
> +
>  /* Given a block of code, recursively resolve everything pointed to by this
>     code block.  */
>


To finish, some spacing errors reported by contrib/check_GNU_style.sh:
> Dot, space, space, new sentence.
> paul_clean.diff:345:+  /* Do the intrinsic assignment. This is not needed if the lhs is one
> paul_clean.diff:466:+  /* Now attach the remaining code chain to the input code. Step on
>
> Dot, space, space, end of comment.
> paul_clean.diff:339:+      /* Add the code and substitute the rhs expression. */
>
> There should be exactly one space between function name and parentheses.
> paul_clean.diff:101:+  *ref = gfc_get_ref();
diff mbox

Patch

diff --git a/expr.c b/expr.c
index 211f304..2491803 100644
--- a/expr.c
+++ b/expr.c
@@ -3897,6 +3897,33 @@  gfc_get_variable_expr (gfc_symtree *var)
 }
 
 
+/* 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)
 {
@@ -3910,16 +3937,8 @@  gfc_lval_expr_from_sym (gfc_symbol *sym)
   /* 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;
-    }
-
+    gfc_add_full_array_ref (lval, sym->ts.type == BT_CLASS ?
+			    CLASS_DATA (sym)->as : sym->as);
   return lval;
 }
 
diff --git a/gfortran.h b/gfortran.h
index fabc16a..3bcffe9 100644
--- a/gfortran.h
+++ b/gfortran.h
@@ -786,9 +786,11 @@  typedef struct
   /* 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.  */
+     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;
+	   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;
@@ -2761,6 +2763,7 @@  gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *);
 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);
diff --git a/resolve.c b/resolve.c
index 53d695c..43ac38c 100644
--- a/resolve.c
+++ b/resolve.c
@@ -9553,6 +9553,396 @@  resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
 }
 
 
+/* 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.  */
+  if (c->as)
+    {
+      gfc_add_full_array_ref (e, c->as);
+      e->rank = c->as->rank;
+    }
+}
+
+
+/* Build an assignment.  Keep the argument 'op' for future use, so that
+   pointer assignments can be made.  */
+
+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_array_spec *as;
+  gfc_array_ref *aref;
+  gfc_ref *ref;
+
+  sprintf (name, "DA@%d", serial++);
+  gfc_get_sym_tree (name, ns, &tmp, false);
+  gfc_add_type (tmp->n.sym, &e->ts, NULL);
+
+  as = NULL;
+  ref = NULL;
+  aref = NULL;
+
+  /* Obtain the arrayspec for the temporary.  */
+  if (e->rank)
+    {
+      aref = gfc_find_array_ref (e);
+      if (e->expr_type == EXPR_VARIABLE
+	  && e->symtree->n.sym->as == aref->as)
+	as = aref->as;
+      else
+	{
+	  for (ref = e->ref; ref; ref = ref->next)
+	    if (ref->type == REF_COMPONENT
+		&& ref->u.c.component->as == aref->as)
+	      {
+		as = aref->as;
+		break;
+	      }
+	  }
+    }
+
+  /* Add the attributes and the arrayspec to the temporary.  */
+  tmp->n.sym->attr = gfc_expr_attr (e);
+  if (as)
+    {
+      tmp->n.sym->as = gfc_copy_array_spec (as);
+      if (!ref)
+	ref = e->ref;
+      if (as->type == AS_DEFERRED)
+	tmp->n.sym->attr.allocatable = 1;
+    }
+  else
+    tmp->n.sym->attr.dimension = 0;
+
+  gfc_set_sym_referenced (tmp->n.sym);
+  gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
+  e = gfc_lval_expr_from_sym (tmp->n.sym);
+
+  /* Should the lhs be a section, use its array ref for the
+     temporary expression.  */
+  if (aref && aref->type != AR_FULL)
+    {
+      gfc_free_ref_list (e->ref);
+      e->ref = gfc_copy_ref (ref);
+    }
+  return e;
+}
+
+
+/* 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;
+}
+
+
+/* Counts the potential number of part array references that would
+   result from resolution of typebound defined assignments.  */
+
+static int
+nonscalar_typebound_assign (gfc_symbol *derived, int depth)
+{
+  gfc_component *c;
+  int c_depth = 0, t_depth;
+
+  for (c= derived->components; c; c = c->next)
+    {
+      if ((c->ts.type != BT_DERIVED
+	  || c->attr.pointer
+	  || c->attr.allocatable
+	  || c->attr.proc_pointer_comp
+	  || c->attr.class_pointer
+	  || c->attr.proc_pointer)
+	  && !c->attr.defined_assign_comp)
+	continue;
+
+      if (c->as && c_depth == 0)
+	c_depth = 1;
+
+      if (c->ts.u.derived->attr.defined_assign_comp)
+	t_depth = nonscalar_typebound_assign (c->ts.u.derived,
+					      c->as ? 1 : 0);
+      else
+	t_depth = 0;
+
+      c_depth = t_depth > c_depth ? t_depth : c_depth;
+    }
+  return depth + c_depth;
+}
+
+
+/* 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.  The recursion is accomplished
+   by calling resolve_code.
+
+   When the lhs in a defined assignment has intent INOUT, we need a
+   temporary for the lhs.  In pseudo-code:
+
+   ! Only call function lhs once.
+      if (lhs is not a constant or an variable)
+	  temp_x = expr2
+          expr2 => temp_x
+   ! Do the intrinsic assignment
+      expr1 = expr2
+   ! Now do the defined assignments
+      do over components with typebound defined assignment [%cmp]
+        if (arg1 of defined assignment procedure is INOUT)
+	    t1%cmp {defined=} expr2%cmp  ! ensures INOUT lhs uses value
+					 ! unaffected by intrinsic assign
+	    expr1%cmp = t1%cmp           ! Store in the result
+	else
+	    expr1%cmp {defined=} expr2%cmp
+      */
+
+/* The temporary assignments have to be put on top of the additional
+   code to avoid the result being changed by the intrinsic assignment.
+   */
+static int component_assignment_level = 0;
+static gfc_code *tmp_head = NULL, *tmp_tail = NULL;
+
+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;
+  int error_count, depth;
+/*  gfc_array_ref *aref;*/
+
+  gfc_get_errors (NULL, &error_count);
+
+  /* Filter out continuing processing after an error.  */
+  if (error_count
+      || (*code)->expr1->ts.type != BT_DERIVED
+      || (*code)->expr2->ts.type != BT_DERIVED)
+    return;
+
+  /* TODO: Handle more than one part array reference in assignments.  */
+  depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived,
+				      (*code)->expr1->rank ? 1 : 0);
+  if (depth > 1)
+    {
+      gfc_warning ("TODO: type-bound defined assignment(s) at %L not "
+		   "done because multiple part array references would "
+		   "occur in intermediate expressions.", &(*code)->loc);
+      return;
+    }
+
+  component_assignment_level++;
+
+  /* Create a temporary so that functions get called only once.  */
+  if ((*code)->expr2->expr_type != EXPR_VARIABLE
+      && (*code)->expr2->expr_type != EXPR_CONSTANT)
+    {
+      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, &tmp_head, &tmp_tail);
+      gfc_free_expr ((*code)->expr2);
+      (*code)->expr2 = tmp_expr;
+    }
+
+  /* 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;
+
+  t1 = NULL;
+  for (; comp1; comp1 = comp1->next, comp2 = comp2->next)
+    {
+      bool inout = false;
+
+      /* 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,
+				    (*code)->expr1, (*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)
+	{
+	  gfc_symbol *rsym;
+	  /* 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;
+	    }
+
+	  /* If the first argument of the subroutine has intent INOUT
+	     a temporary must be generated and used instead.  */
+	  rsym = this_code->resolved_sym;
+	  if (rsym->formal
+	      && rsym->formal->sym->attr.intent == INTENT_INOUT)
+	    {
+	      gfc_code *temp_code;
+	      inout = true;
+
+	      /* Build the temporary required for the assignment and put
+		 it at the head of the generated code.  */
+	      if (!t1)
+		{
+		  t1 = get_temp_from_expr ((*code)->expr1, ns);
+		  temp_code = build_assignment (EXEC_ASSIGN,
+						t1, (*code)->expr1,
+				NULL, NULL, (*code)->loc);
+	          add_code_to_chain (&temp_code, &tmp_head, &tmp_tail);
+		}
+
+	      /* Replace the first actual arg with the component of the
+		 temporary.  */
+	      gfc_free_expr (this_code->ext.actual->expr);
+	      this_code->ext.actual->expr = gfc_copy_expr (t1);
+	      add_comp_ref (this_code->ext.actual->expr, comp1);
+	    }
+	  }
+      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);
+	  this_code = NULL;
+	  continue;
+	}
+
+      add_code_to_chain (&this_code, &head, &tail);
+
+      if (t1 && inout)
+	{
+	  /* 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);
+	}
+    }
+
+  if (this_code)
+    {
+      gfc_free_statements (this_code);
+      this_code = NULL;
+    }
+
+  /* Put the temporary assignments at the top of the generated code.  */
+  if (tmp_head && component_assignment_level == 1)
+    {
+      gfc_append_code (tmp_head, head);
+      head = tmp_head;
+      tmp_head = tmp_tail = NULL;
+    }
+
+  /* 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;
+
+  component_assignment_level--;
+}
+
+
 /* Given a block of code, recursively resolve everything pointed to by this
    code block.  */
 
@@ -9715,6 +10105,12 @@  resolve_code (gfc_code *code, gfc_namespace *ns)
 	      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:
@@ -11948,6 +12344,43 @@  ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor)
 }
 
 
+/* This check for typebound defined assignments is done recursively
+   since the order in which derived types are resolved is not always in
+   order of the declarations.  */
+
+static void
+check_defined_assignments (gfc_symbol *derived)
+{
+  gfc_component *c;
+
+  for (c = derived->components; c; c = c->next)
+    {
+      if (c->ts.type != BT_DERIVED
+	  || c->attr.pointer
+	  || c->attr.allocatable
+	  || c->attr.proc_pointer_comp
+	  || c->attr.class_pointer
+	  || c->attr.proc_pointer)
+	continue;
+
+      if (c->ts.u.derived->attr.defined_assign_comp
+	  || (c->ts.u.derived->f2k_derived
+	     && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN]))
+	{
+	  derived->attr.defined_assign_comp = 1;
+	  return;
+	}
+
+      check_defined_assignments (c->ts.u.derived);
+      if (c->ts.u.derived->attr.defined_assign_comp)
+	{
+	  derived->attr.defined_assign_comp = 1;
+	  return;
+	}
+    }
+}
+
+
 /* Resolve the components of a derived type. This does not have to wait until
    resolution stage, but can be done as soon as the dt declaration has been
    parsed.  */
@@ -12345,6 +12778,12 @@  resolve_fl_derived0 (gfc_symbol *sym)
 	return FAILURE;
     }
 
+  check_defined_assignments (sym);
+
+  if (!sym->attr.defined_assign_comp && 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
@@ -14402,6 +14841,7 @@  gfc_resolve (gfc_namespace *ns)
   old_cs_base = cs_base;
 
   resolve_types (ns);
+  component_assignment_level = 0;
   resolve_codes (ns);
 
   gfc_current_ns = old_ns;