Patchwork [fortran] PR46328 - [OOP] type-bound operator call with non-trivial polymorphic operand

login
register
mail settings
Submitter Paul Richard Thomas
Date Dec. 30, 2011, 7:27 p.m.
Message ID <CAGkQGi+v+YkRnyo2TUZ_Z8FXb4wkPO49Y+GkKmE=bEAXNyzDLA@mail.gmail.com>
Download mbox | patch
Permalink /patch/133693/
State New
Headers show

Comments

Paul Richard Thomas - Dec. 30, 2011, 7:27 p.m.
Dear All,

This patch represents a rather complete fix for this PR.  In fact, I
suspect that it also fixes other PRs but I have been out of internet
range for a week and have not been able to check.

The processing of typebound operators has been made more straight
forward here by the addition of a new field in gfc_expression to hold
the base object expression.  I tried to avoid this but ran into a mess
of other problems in resolution, when I tried to do otherwise.  It
turns out that this works well,however, so another pointer in the
gfc_expr seems a small price to pay.  A big plus, which has not been
tested in the testcase submitted but will be in future patches, is
that the handling of the typebound operators and procedures now admits
the base object changing dynamic type in the course of the call.

Another essential part of the patch involves the triming of extraneous
trailing references in the base object expressions, such as _vptrs and
so on.

Finally, the patch includes two extra bits: one brings back the
nullification of newly assigned class array _data. (Tobias, is there a
PR for this?); The other is to fix pointer assignment of class valued
procedure pointers.  This permits a fully elaborated version of Arjen
Markus's pde solver to compile and run correctly - of which a bit more
in one of two following emails to the fortran list.

Bootstrapped and regtested on i686/Ubuntu 11.1 - OK for trunk?

A Happy New Year to one and all!

Paul

2011-12-30  Paul Thomas  <pault@gcc.gnu.org>

	* trans-array.c (gfc_array_allocate): Null allocated memory of
	newly allocted class arrays.

	PR fortran/46328
	* interface.c(build_compcall_for_operator): Add a type to the
	expression.
	* trans-expr.c (conv_base_obj_fcn_val): New function.
	(gfc_conv_procedure_call): Use base_expr to detect non-variable
	base objects and, ensuring that there is a temporary variable,
	build up the typebound call using conv_base_obj_fcn_val.
	(gfc_trans_class_assign): Pick out class procedure pointer
	assignments and do the assignment with no further prcessing.
	* gfortran.h : Add 'base_expr' field to gfc_expr.
	* resolve.c (get_declared_from_expr): Add 'types' argument to
	switch checking of derived types on or off.
	(resolve_typebound_generic_call): Set the new argument.
	(resolve_typebound_function, resolve_typebound_subroutine):
	Set 'types' argument for get_declared_from_expr appropriately.
	Identify base expression, if not a variable, in the argument
	list of class valued calls. Assign it to the 'base_expr' field
	of the final expression. Strip away all references after the
	last class reference.


2011-12-30  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/46328
	* gfortran.dg/typebound_operator_7.f03: New.
Tobias Burnus - Dec. 30, 2011, 11:14 p.m.
Dear Paul,

Paul Richard Thomas wrote:
> Bootstrapped and regtested on i686/Ubuntu 11.1 - OK for trunk?
>
> 2011-12-30  Paul Thomas<pault@gcc.gnu.org>
>
> 	* trans-array.c (gfc_array_allocate): Null allocated memory of
> 	newly allocted class arrays.

PR fortran/51529

> 	PR fortran/46328
> 	* interface.c(build_compcall_for_operator): Add a type to the
> 	expression.

You might want to quote additionally PR fortran/51052 and PR fortran/51052.

> *** gcc/fortran/interface.c	(revision 182566)
> --- gcc/fortran/interface.c	(working copy)
> ***************
> *** 3256,3261 ****
> --- 3256,3269 ----

I would have liked a diff with "-p" flag which shows the function name 
in the diff (for instance "svn diff -x -p" or "svn diff -x '-p -u'").

>
> +   if (expr->ts.type == BT_CLASS&&  expr3)
> +     {
> +       tmp = build_int_cst (unsigned_char_type_node, 0);
> +       /* With class objects, it is best to play safe and null the
> + 	 memory because we cannot know if dynamic types have allocatable
> + 	 components or not.  */

I don't like the comment; how about something along the following: "For 
class objects we need to nullify the memory in case they have 
allocatable components; the reason is that _copy, which is used for 
initialization, first frees the destination."


> + gfc_trans_class_init_assign (gfc_code *code)
> + {
> +   stmtblock_t block;
> +   tree tmp;
> +   gfc_se dst,src,memsz;

Space after each comma.

> +   gfc_expr *lhs,*rhs,*sz;

Ditto.


> ***************
> *** 3301,3306 ****
> --- 3502,3514 ----
>    		{
>    		  gfc_conv_expr_reference (&parmse, e);
>
> + 		  /* Catch base objects that are not variables.  */
> + 		  if (e->ts.type == BT_CLASS
> + 			&&  e->expr_type != EXPR_VARIABLE
> + 			&&  expr&&  e == expr->base_expr)

The indentation looks wrong.


> + 	  for (args= e->value.function.actual; args; args = args->next)
> + 	    {
> + 	      if (expr == args->expr)
> + 		expr = args->expr;
> + 	    }

Space before the equal sign in "args=". If you want, you can also remove 
the curly braces as they are not required.

> + 	  args= code->expr1->value.function.actual;
> + 	  for (; args; args = args->next)
> + 	    {
> + 	      if (expr == args->expr)
> + 		expr = args->expr;
> + 	    }

Ditto.

>    get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
> ! 			gfc_expr *e)
> --- 5623,5629 ----
>    get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
> ! 			gfc_expr *e, bool types)

I think "types" deserves a comment line in the comment block before the 
function; additionally - and related - I wonder whether the name is well 
chosen. "types" reminds me of "bt" rather than of "bool". In the 
changelog, you use: "Add 'types' argument to switch checking of derived 
types on or off." Thus, "check_types" would be a possible choice.

Otherwise, the patch looks okay to me.

Happy new year to every one!

Tobias
Paul Richard Thomas - Dec. 31, 2011, 8:44 a.m.
Dear Tobias,

Many thanks for the review and your replies to redux(1)/(2).

I will take account of your comments and commit tomorrow night.

I have a fix for the allocation of class temporaries, which cures the
problem with index vectors.... It will see the light of day on Monday.

Happy New Year to one and all.

Paul

On Sat, Dec 31, 2011 at 12:14 AM, Tobias Burnus <burnus@net-b.de> wrote:
> Dear Paul,
>
> Paul Richard Thomas wrote:
>>
>> Bootstrapped and regtested on i686/Ubuntu 11.1 - OK for trunk?
>>
>> 2011-12-30  Paul Thomas<pault@gcc.gnu.org>
>>
>>        * trans-array.c (gfc_array_allocate): Null allocated memory of
>>        newly allocted class arrays.
>
>
> PR fortran/51529
>
>
>>        PR fortran/46328
>>        * interface.c(build_compcall_for_operator): Add a type to the
>>        expression.
>
>
> You might want to quote additionally PR fortran/51052 and PR fortran/51052.
>
>> *** gcc/fortran/interface.c     (revision 182566)
>> --- gcc/fortran/interface.c     (working copy)
>> ***************
>> *** 3256,3261 ****
>> --- 3256,3269 ----
>
>
> I would have liked a diff with "-p" flag which shows the function name in
> the diff (for instance "svn diff -x -p" or "svn diff -x '-p -u'").
>
>>
>> +   if (expr->ts.type == BT_CLASS&&  expr3)
>> +     {
>> +       tmp = build_int_cst (unsigned_char_type_node, 0);
>> +       /* With class objects, it is best to play safe and null the
>> +        memory because we cannot know if dynamic types have allocatable
>> +        components or not.  */
>
>
> I don't like the comment; how about something along the following: "For
> class objects we need to nullify the memory in case they have allocatable
> components; the reason is that _copy, which is used for initialization,
> first frees the destination."
>
>
>> + gfc_trans_class_init_assign (gfc_code *code)
>> + {
>> +   stmtblock_t block;
>> +   tree tmp;
>> +   gfc_se dst,src,memsz;
>
>
> Space after each comma.
>
>> +   gfc_expr *lhs,*rhs,*sz;
>
>
> Ditto.
>
>
>> ***************
>> *** 3301,3306 ****
>> --- 3502,3514 ----
>>                {
>>                  gfc_conv_expr_reference (&parmse, e);
>>
>> +                 /* Catch base objects that are not variables.  */
>> +                 if (e->ts.type == BT_CLASS
>> +                       &&  e->expr_type != EXPR_VARIABLE
>> +                       &&  expr&&  e == expr->base_expr)
>
>
> The indentation looks wrong.
>
>
>> +         for (args= e->value.function.actual; args; args = args->next)
>> +           {
>> +             if (expr == args->expr)
>> +               expr = args->expr;
>> +           }
>
>
> Space before the equal sign in "args=". If you want, you can also remove the
> curly braces as they are not required.
>
>> +         args= code->expr1->value.function.actual;
>> +         for (; args; args = args->next)
>> +           {
>> +             if (expr == args->expr)
>> +               expr = args->expr;
>> +           }
>
>
> Ditto.
>
>>   get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
>> !                       gfc_expr *e)
>> --- 5623,5629 ----
>>   get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
>> !                       gfc_expr *e, bool types)
>
>
> I think "types" deserves a comment line in the comment block before the
> function; additionally - and related - I wonder whether the name is well
> chosen. "types" reminds me of "bt" rather than of "bool". In the changelog,
> you use: "Add 'types' argument to switch checking of derived types on or
> off." Thus, "check_types" would be a possible choice.
>
> Otherwise, the patch looks okay to me.
>
> Happy new year to every one!
>
> Tobias

Patch

Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c	(revision 182566)
--- gcc/fortran/interface.c	(working copy)
***************
*** 3256,3261 ****
--- 3256,3269 ----
    e->value.compcall.base_object = base;
    e->value.compcall.ignore_pass = 1;
    e->value.compcall.assign = 0;
+   if (e->ts.type == BT_UNKNOWN
+ 	&& target->function)
+     {
+       if (target->is_generic)
+ 	e->ts = target->u.generic->specific->u.specific->n.sym->ts;
+       else
+ 	e->ts = target->u.specific->n.sym->ts;
+     }
  }
  
  
***************
*** 3383,3389 ****
  
  	  gcc_assert (tb_base);
  	  build_compcall_for_operator (e, actual, tb_base, tbo, gname);
- 
  	  result = gfc_resolve_expr (e);
  	  if (result == FAILURE)
  	    return MATCH_ERROR;
--- 3391,3396 ----
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 182566)
--- gcc/fortran/trans-array.c	(working copy)
***************
*** 5069,5074 ****
--- 5069,5086 ----
  
    gfc_add_expr_to_block (&se->pre, tmp);
  
+   if (expr->ts.type == BT_CLASS && expr3)
+     {
+       tmp = build_int_cst (unsigned_char_type_node, 0);
+       /* With class objects, it is best to play safe and null the 
+ 	 memory because we cannot know if dynamic types have allocatable
+ 	 components or not.  */
+       tmp = build_call_expr_loc (input_location,
+ 				 builtin_decl_explicit (BUILT_IN_MEMSET),
+ 				 3, pointer, tmp,  size);
+       gfc_add_expr_to_block (&se->pre, tmp);
+     }
+ 
    /* Update the array descriptors. */
    if (dimension)
      gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 182566)
--- gcc/fortran/trans-expr.c	(working copy)
***************
*** 302,307 ****
--- 302,480 ----
    parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
  }
  
+ 
+ static tree
+ gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
+ {
+   gfc_actual_arglist *actual;
+   gfc_expr *ppc;
+   gfc_code *ppc_code;
+   tree res;
+ 
+   actual = gfc_get_actual_arglist ();
+   actual->expr = gfc_copy_expr (rhs);
+   actual->next = gfc_get_actual_arglist ();
+   actual->next->expr = gfc_copy_expr (lhs);
+   ppc = gfc_copy_expr (obj);
+   gfc_add_vptr_component (ppc);
+   gfc_add_component_ref (ppc, "_copy");
+   ppc_code = gfc_get_code ();
+   ppc_code->resolved_sym = ppc->symtree->n.sym;
+   /* Although '_copy' is set to be elemental in class.c, it is
+      not staying that way.  Find out why, sometime....  */
+   ppc_code->resolved_sym->attr.elemental = 1;
+   ppc_code->ext.actual = actual;
+   ppc_code->expr1 = ppc;
+   ppc_code->op = EXEC_CALL;
+   /* Since '_copy' is elemental, the scalarizer will take care
+      of arrays in gfc_trans_call.  */
+   res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
+   gfc_free_statements (ppc_code);
+   return res;
+ }
+ 
+ /* Special case for initializing a polymorphic dummy with INTENT(OUT).
+    A MEMCPY is needed to copy the full data from the default initializer
+    of the dynamic type.  */
+ 
+ tree
+ gfc_trans_class_init_assign (gfc_code *code)
+ {
+   stmtblock_t block;
+   tree tmp;
+   gfc_se dst,src,memsz;
+   gfc_expr *lhs,*rhs,*sz;
+ 
+   gfc_start_block (&block);
+ 
+   lhs = gfc_copy_expr (code->expr1);
+   gfc_add_data_component (lhs);
+ 
+   rhs = gfc_copy_expr (code->expr1);
+   gfc_add_vptr_component (rhs);
+ 
+   /* Make sure that the component backend_decls have been built, which
+      will not have happened if the derived types concerned have not
+      been referenced.  */
+   gfc_get_derived_type (rhs->ts.u.derived);
+   gfc_add_def_init_component (rhs);
+ 
+   if (code->expr1->ts.type == BT_CLASS
+ 	&& CLASS_DATA (code->expr1)->attr.dimension)
+     tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
+   else
+     {
+       sz = gfc_copy_expr (code->expr1);
+       gfc_add_vptr_component (sz);
+       gfc_add_size_component (sz);
+ 
+       gfc_init_se (&dst, NULL);
+       gfc_init_se (&src, NULL);
+       gfc_init_se (&memsz, NULL);
+       gfc_conv_expr (&dst, lhs);
+       gfc_conv_expr (&src, rhs);
+       gfc_conv_expr (&memsz, sz);
+       gfc_add_block_to_block (&block, &src.pre);
+       tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
+     }
+   gfc_add_expr_to_block (&block, tmp);
+   
+   return gfc_finish_block (&block);
+ }
+ 
+ 
+ /* Translate an assignment to a CLASS object
+    (pointer or ordinary assignment).  */
+ 
+ tree
+ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
+ {
+   stmtblock_t block;
+   tree tmp;
+   gfc_expr *lhs;
+   gfc_expr *rhs;
+   gfc_ref *ref;
+ 
+   gfc_start_block (&block);
+ 
+   ref = expr1->ref;
+   while (ref && ref->next)
+      ref = ref->next;
+ 
+   /* Class valued proc_pointer assignments do not need any further
+      preparation.  */
+   if (ref && ref->type == REF_COMPONENT
+ 	&& ref->u.c.component->attr.proc_pointer
+ 	&& expr2->expr_type == EXPR_VARIABLE
+ 	&& expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE
+ 	&& op == EXEC_POINTER_ASSIGN)
+     goto assign;
+ 
+   if (expr2->ts.type != BT_CLASS)
+     {
+       /* Insert an additional assignment which sets the '_vptr' field.  */
+       gfc_symbol *vtab = NULL;
+       gfc_symtree *st;
+ 
+       lhs = gfc_copy_expr (expr1);
+       gfc_add_vptr_component (lhs);
+ 
+       if (expr2->ts.type == BT_DERIVED)
+ 	vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
+       else if (expr2->expr_type == EXPR_NULL)
+ 	vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
+       gcc_assert (vtab);
+ 
+       rhs = gfc_get_expr ();
+       rhs->expr_type = EXPR_VARIABLE;
+       gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
+       rhs->symtree = st;
+       rhs->ts = vtab->ts;
+ 
+       tmp = gfc_trans_pointer_assignment (lhs, rhs);
+       gfc_add_expr_to_block (&block, tmp);
+ 
+       gfc_free_expr (lhs);
+       gfc_free_expr (rhs);
+     }
+   else if (CLASS_DATA (expr2)->attr.dimension)
+     {
+       /* Insert an additional assignment which sets the '_vptr' field.  */
+       lhs = gfc_copy_expr (expr1);
+       gfc_add_vptr_component (lhs);
+ 
+       rhs = gfc_copy_expr (expr2);
+       gfc_add_vptr_component (rhs);
+ 
+       tmp = gfc_trans_pointer_assignment (lhs, rhs);
+       gfc_add_expr_to_block (&block, tmp);
+ 
+       gfc_free_expr (lhs);
+       gfc_free_expr (rhs);
+     }
+ 
+   /* Do the actual CLASS assignment.  */
+   if (expr2->ts.type == BT_CLASS
+ 	&& !CLASS_DATA (expr2)->attr.dimension)
+     op = EXEC_ASSIGN;
+   else
+     gfc_add_data_component (expr1);
+ 
+ assign:
+ 
+   if (op == EXEC_ASSIGN)
+     tmp = gfc_trans_assignment (expr1, expr2, false, true);
+   else if (op == EXEC_POINTER_ASSIGN)
+     tmp = gfc_trans_pointer_assignment (expr1, expr2);
+   else
+     gcc_unreachable();
+ 
+   gfc_add_expr_to_block (&block, tmp);
+ 
+   return gfc_finish_block (&block);
+ }
+ 
+ 
  /* End of prototype trans-class.c  */
  
  
***************
*** 1976,1981 ****
--- 2149,2179 ----
  }
  
  
+ /* Convert a typebound function reference from a class object.  */
+ static void
+ conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
+ {
+   gfc_ref *ref;
+   tree var;
+ 
+   if (TREE_CODE (base_object) != VAR_DECL)
+     {
+       var = gfc_create_var (TREE_TYPE (base_object), NULL);
+       gfc_add_modify (&se->pre, var, base_object);
+     }
+   se->expr = gfc_class_vptr_get (base_object);
+   se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+   ref = expr->ref;
+   while (ref && ref->next)
+     ref = ref->next;
+   gcc_assert (ref && ref->type == REF_COMPONENT);
+   if (ref->u.c.sym->attr.extension)
+     conv_parent_component_references (se, ref);
+   gfc_conv_component_ref (se, ref);
+   se->expr = build_fold_addr_expr_loc (input_location, se->expr);
+ }
+ 
+ 
  static void
  conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
  {
***************
*** 3084,3089 ****
--- 3282,3288 ----
    tree type;
    tree var;
    tree len;
+   tree base_object;
    VEC(tree,gc) *stringargs;
    tree result = NULL;
    gfc_formal_arglist *formal;
***************
*** 3156,3161 ****
--- 3355,3362 ----
  				   != EXPR_CONSTANT);
      }
  
+   base_object = NULL_TREE;
+ 
    /* Evaluate the arguments.  */
    for (arg = args; arg != NULL;
         arg = arg->next, formal = formal ? formal->next : NULL)
***************
*** 3301,3306 ****
--- 3502,3514 ----
  		{
  		  gfc_conv_expr_reference (&parmse, e);
  
+ 		  /* Catch base objects that are not variables.  */
+ 		  if (e->ts.type == BT_CLASS
+ 			&& e->expr_type != EXPR_VARIABLE
+ 			&& expr && e == expr->base_expr)
+ 		    base_object = build_fold_indirect_ref_loc (input_location,
+ 							       parmse.expr);
+ 
  		  /* A class array element needs converting back to be a
  		     class object, if the formal argument is a class object.  */
  		  if (fsym && fsym->ts.type == BT_CLASS
***************
*** 4000,4006 ****
    arglist = retargs;
  
    /* Generate the actual call.  */
!   conv_function_val (se, sym, expr);
  
    /* If there are alternate return labels, function type should be
       integer.  Can't modify the type in place though, since it can be shared
--- 4208,4217 ----
    arglist = retargs;
  
    /* Generate the actual call.  */
!   if (base_object == NULL_TREE)
!     conv_function_val (se, sym, expr);
!   else
!     conv_base_obj_fcn_val (se, base_object, expr);
  
    /* If there are alternate return labels, function type should be
       integer.  Can't modify the type in place though, since it can be shared
***************
*** 5294,5300 ****
        return;
      }
  
- 
    gfc_conv_expr (se, expr);
  
    /* Create a temporary var to hold the value.  */
--- 5505,5510 ----
***************
*** 6730,6887 ****
  {
    return gfc_trans_assignment (code->expr1, code->expr2, false, true);
  }
- 
- 
- static tree
- gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
- {
-   gfc_actual_arglist *actual;
-   gfc_expr *ppc;
-   gfc_code *ppc_code;
-   tree res;
- 
-   actual = gfc_get_actual_arglist ();
-   actual->expr = gfc_copy_expr (rhs);
-   actual->next = gfc_get_actual_arglist ();
-   actual->next->expr = gfc_copy_expr (lhs);
-   ppc = gfc_copy_expr (obj);
-   gfc_add_vptr_component (ppc);
-   gfc_add_component_ref (ppc, "_copy");
-   ppc_code = gfc_get_code ();
-   ppc_code->resolved_sym = ppc->symtree->n.sym;
-   /* Although '_copy' is set to be elemental in class.c, it is
-      not staying that way.  Find out why, sometime....  */
-   ppc_code->resolved_sym->attr.elemental = 1;
-   ppc_code->ext.actual = actual;
-   ppc_code->expr1 = ppc;
-   ppc_code->op = EXEC_CALL;
-   /* Since '_copy' is elemental, the scalarizer will take care
-      of arrays in gfc_trans_call.  */
-   res = gfc_trans_call (ppc_code, false, NULL, NULL, false);
-   gfc_free_statements (ppc_code);
-   return res;
- }
- 
- /* Special case for initializing a polymorphic dummy with INTENT(OUT).
-    A MEMCPY is needed to copy the full data from the default initializer
-    of the dynamic type.  */
- 
- tree
- gfc_trans_class_init_assign (gfc_code *code)
- {
-   stmtblock_t block;
-   tree tmp;
-   gfc_se dst,src,memsz;
-   gfc_expr *lhs,*rhs,*sz;
- 
-   gfc_start_block (&block);
- 
-   lhs = gfc_copy_expr (code->expr1);
-   gfc_add_data_component (lhs);
- 
-   rhs = gfc_copy_expr (code->expr1);
-   gfc_add_vptr_component (rhs);
- 
-   /* Make sure that the component backend_decls have been built, which
-      will not have happened if the derived types concerned have not
-      been referenced.  */
-   gfc_get_derived_type (rhs->ts.u.derived);
-   gfc_add_def_init_component (rhs);
- 
-   if (code->expr1->ts.type == BT_CLASS
- 	&& CLASS_DATA (code->expr1)->attr.dimension)
-     tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1);
-   else
-     {
-       sz = gfc_copy_expr (code->expr1);
-       gfc_add_vptr_component (sz);
-       gfc_add_size_component (sz);
- 
-       gfc_init_se (&dst, NULL);
-       gfc_init_se (&src, NULL);
-       gfc_init_se (&memsz, NULL);
-       gfc_conv_expr (&dst, lhs);
-       gfc_conv_expr (&src, rhs);
-       gfc_conv_expr (&memsz, sz);
-       gfc_add_block_to_block (&block, &src.pre);
-       tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
-     }
-   gfc_add_expr_to_block (&block, tmp);
-   
-   return gfc_finish_block (&block);
- }
- 
- 
- /* Translate an assignment to a CLASS object
-    (pointer or ordinary assignment).  */
- 
- tree
- gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
- {
-   stmtblock_t block;
-   tree tmp;
-   gfc_expr *lhs;
-   gfc_expr *rhs;
- 
-   gfc_start_block (&block);
- 
-   if (expr2->ts.type != BT_CLASS)
-     {
-       /* Insert an additional assignment which sets the '_vptr' field.  */
-       gfc_symbol *vtab = NULL;
-       gfc_symtree *st;
- 
-       lhs = gfc_copy_expr (expr1);
-       gfc_add_vptr_component (lhs);
- 
-       if (expr2->ts.type == BT_DERIVED)
- 	vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
-       else if (expr2->expr_type == EXPR_NULL)
- 	vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
-       gcc_assert (vtab);
- 
-       rhs = gfc_get_expr ();
-       rhs->expr_type = EXPR_VARIABLE;
-       gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
-       rhs->symtree = st;
-       rhs->ts = vtab->ts;
- 
-       tmp = gfc_trans_pointer_assignment (lhs, rhs);
-       gfc_add_expr_to_block (&block, tmp);
- 
-       gfc_free_expr (lhs);
-       gfc_free_expr (rhs);
-     }
-   else if (CLASS_DATA (expr2)->attr.dimension)
-     {
-       /* Insert an additional assignment which sets the '_vptr' field.  */
-       lhs = gfc_copy_expr (expr1);
-       gfc_add_vptr_component (lhs);
- 
-       rhs = gfc_copy_expr (expr2);
-       gfc_add_vptr_component (rhs);
- 
-       tmp = gfc_trans_pointer_assignment (lhs, rhs);
-       gfc_add_expr_to_block (&block, tmp);
- 
-       gfc_free_expr (lhs);
-       gfc_free_expr (rhs);
-     }
- 
-   /* Do the actual CLASS assignment.  */
-   if (expr2->ts.type == BT_CLASS && !CLASS_DATA (expr2)->attr.dimension)
-     op = EXEC_ASSIGN;
-   else
-     gfc_add_data_component (expr1);
- 
-   if (op == EXEC_ASSIGN)
-     tmp = gfc_trans_assignment (expr1, expr2, false, true);
-   else if (op == EXEC_POINTER_ASSIGN)
-     tmp = gfc_trans_pointer_assignment (expr1, expr2);
-   else
-     gcc_unreachable();
- 
-   gfc_add_expr_to_block (&block, tmp);
- 
-   return gfc_finish_block (&block);
- }
--- 6940,6942 ----
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 182566)
--- gcc/fortran/gfortran.h	(working copy)
***************
*** 1697,1702 ****
--- 1697,1706 ----
  
    locus where;
  
+   /* Used to store the base expression in component calls, when the expression
+      is not a variable.  */
+   gfc_expr *base_expr;
+ 
    /* is_boz is true if the integer is regarded as BOZ bitpatten and is_snan
       denotes a signalling not-a-number.  */
    unsigned int is_boz : 1, is_snan : 1;
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 182566)
--- gcc/fortran/resolve.c	(working copy)
***************
*** 5623,5629 ****
     reference list.  */
  static gfc_symbol*
  get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
! 			gfc_expr *e)
  {
    gfc_symbol *declared;
    gfc_ref *ref;
--- 5623,5629 ----
     reference list.  */
  static gfc_symbol*
  get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
! 			gfc_expr *e, bool types)
  {
    gfc_symbol *declared;
    gfc_ref *ref;
***************
*** 5639,5646 ****
        if (ref->type != REF_COMPONENT)
  	continue;
  
!       if (ref->u.c.component->ts.type == BT_CLASS
! 	    || ref->u.c.component->ts.type == BT_DERIVED)
  	{
  	  declared = ref->u.c.component->ts.u.derived;
  	  if (class_ref)
--- 5639,5647 ----
        if (ref->type != REF_COMPONENT)
  	continue;
  
!       if ((ref->u.c.component->ts.type == BT_CLASS
! 	      || (types && ref->u.c.component->ts.type == BT_DERIVED))
! 	    && ref->u.c.component->attr.flavor != FL_PROCEDURE)
  	{
  	  declared = ref->u.c.component->ts.u.derived;
  	  if (class_ref)
***************
*** 5735,5741 ****
  
  success:
    /* Make sure that we have the right specific instance for the name.  */
!   derived = get_declared_from_expr (NULL, NULL, e);
  
    st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
    if (st)
--- 5736,5742 ----
  
  success:
    /* Make sure that we have the right specific instance for the name.  */
!   derived = get_declared_from_expr (NULL, NULL, e, true);
  
    st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
    if (st)
***************
*** 5872,5877 ****
--- 5873,5893 ----
    overridable = !e->value.compcall.tbp->non_overridable;
    if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name)
      {
+       /* If the base_object is not a variable, the corresponding actual
+ 	 argument expression must be stored in e->base_expression so
+ 	 that the corresponding tree temporary can be used as the base
+ 	 object in gfc_conv_procedure_call.  */
+       if (expr->expr_type != EXPR_VARIABLE)
+ 	{
+ 	  gfc_actual_arglist *args;
+ 
+ 	  for (args= e->value.function.actual; args; args = args->next)
+ 	    {
+ 	      if (expr == args->expr)
+ 		expr = args->expr;
+ 	    }
+ 	}
+ 
        /* Since the typebound operators are generic, we have to ensure
  	 that any delays in resolution are corrected and that the vtab
  	 is present.  */
***************
*** 5888,5896 ****
--- 5904,5930 ----
        name = name ? name : e->value.function.esym->name;
        e->symtree = expr->symtree;
        e->ref = gfc_copy_ref (expr->ref);
+ 
+       /* Trim away the extraneous references that emerge from nested
+ 	 use of interface.c (extend_expr).  */
+       get_declared_from_expr (&class_ref, NULL, e, false);
+       if (class_ref && class_ref->next)
+ 	{
+ 	  gfc_free_ref_list (class_ref->next);
+ 	  class_ref->next = NULL;
+ 	}
+       else if (e->ref && !class_ref)
+ 	{
+ 	  gfc_free_ref_list (e->ref);
+ 	  e->ref = NULL;
+ 	}
+ 
+       /* Now use the procedure in the vtable.  */
        gfc_add_vptr_component (e);
        gfc_add_component_ref (e, name);
        e->value.function.esym = NULL;
+       if (expr->expr_type != EXPR_VARIABLE)
+ 	e->base_expr = expr;
        return SUCCESS;
      }
  
***************
*** 5901,5907 ****
      return FAILURE;
  
    /* Get the CLASS declared type.  */
!   declared = get_declared_from_expr (&class_ref, &new_ref, e);
  
    /* Weed out cases of the ultimate component being a derived type.  */
    if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
--- 5935,5941 ----
      return FAILURE;
  
    /* Get the CLASS declared type.  */
!   declared = get_declared_from_expr (&class_ref, &new_ref, e, true);
  
    /* Weed out cases of the ultimate component being a derived type.  */
    if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
***************
*** 5967,5972 ****
--- 6001,6022 ----
    overridable = !code->expr1->value.compcall.tbp->non_overridable;
    if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name)
      {
+       /* If the base_object is not a variable, the corresponding actual
+ 	 argument expression must be stored in e->base_expression so
+ 	 that the corresponding tree temporary can be used as the base
+ 	 object in gfc_conv_procedure_call.  */
+       if (expr->expr_type != EXPR_VARIABLE)
+ 	{
+ 	  gfc_actual_arglist *args;
+ 
+ 	  args= code->expr1->value.function.actual;
+ 	  for (; args; args = args->next)
+ 	    {
+ 	      if (expr == args->expr)
+ 		expr = args->expr;
+ 	    }
+ 	}
+ 
        /* Since the typebound operators are generic, we have to ensure
  	 that any delays in resolution are corrected and that the vtab
  	 is present.  */
***************
*** 5982,5990 ****
--- 6032,6058 ----
        name = name ? name : code->expr1->value.function.esym->name;
        code->expr1->symtree = expr->symtree;
        code->expr1->ref = gfc_copy_ref (expr->ref);
+ 
+       /* Trim away the extraneous references that emerge from nested
+ 	 use of interface.c (extend_expr).  */
+       get_declared_from_expr (&class_ref, NULL, code->expr1, false);
+       if (class_ref && class_ref->next)
+ 	{
+ 	  gfc_free_ref_list (class_ref->next);
+ 	  class_ref->next = NULL;
+ 	}
+       else if (code->expr1->ref && !class_ref)
+ 	{
+ 	  gfc_free_ref_list (code->expr1->ref);
+ 	  code->expr1->ref = NULL;
+ 	}
+ 
+       /* Now use the procedure in the vtable.  */
        gfc_add_vptr_component (code->expr1);
        gfc_add_component_ref (code->expr1, name);
        code->expr1->value.function.esym = NULL;
+       if (expr->expr_type != EXPR_VARIABLE)
+ 	code->expr1->base_expr = expr;
        return SUCCESS;
      }
  
***************
*** 5995,6001 ****
      return FAILURE;
  
    /* Get the CLASS declared type.  */
!   get_declared_from_expr (&class_ref, &new_ref, code->expr1);
  
    /* Weed out cases of the ultimate component being a derived type.  */
    if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
--- 6063,6069 ----
      return FAILURE;
  
    /* Get the CLASS declared type.  */
!   get_declared_from_expr (&class_ref, &new_ref, code->expr1, true);
  
    /* Weed out cases of the ultimate component being a derived type.  */
    if ((class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
Index: gcc/testsuite/gfortran.dg/typebound_operator_7.f03
===================================================================
*** gcc/testsuite/gfortran.dg/typebound_operator_7.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/typebound_operator_7.f03	(revision 0)
***************
*** 0 ****
--- 1,103 ----
+ ! { dg-do run }
+ ! PR46328 - complex expressions involving typebound operators of class objects.
+ !
+ module field_module
+   implicit none
+   type ,abstract :: field
+   contains
+     procedure(field_op_real) ,deferred :: multiply_real
+     procedure(field_plus_field) ,deferred :: plus
+     procedure(assign_field) ,deferred :: assn
+     generic :: operator(*) => multiply_real
+     generic :: operator(+) => plus
+     generic :: ASSIGNMENT(=) => assn
+   end type
+   abstract interface
+     function field_plus_field(lhs,rhs)
+       import :: field
+       class(field) ,intent(in)  :: lhs
+       class(field) ,intent(in)  :: rhs
+       class(field) ,allocatable :: field_plus_field
+     end function
+   end interface
+   abstract interface
+     function field_op_real(lhs,rhs)
+       import :: field
+       class(field) ,intent(in)  :: lhs
+       real ,intent(in) :: rhs
+       class(field) ,allocatable :: field_op_real
+     end function
+   end interface
+   abstract interface
+     subroutine assign_field(lhs,rhs)
+       import :: field
+       class(field) ,intent(OUT)  :: lhs
+       class(field) ,intent(IN)  :: rhs
+     end subroutine
+   end interface
+ end module
+ 
+ module i_field_module
+   use field_module
+   implicit none
+   type, extends (field)  :: i_field
+     integer :: i
+   contains
+     procedure :: multiply_real => i_multiply_real
+     procedure :: plus => i_plus_i
+     procedure :: assn => i_assn
+   end type
+ contains
+   function i_plus_i(lhs,rhs)
+     class(i_field) ,intent(in)  :: lhs
+     class(field) ,intent(in)  :: rhs
+     class(field) ,allocatable :: i_plus_i
+     integer :: m = 0
+     select type (lhs)
+       type is (i_field); m = lhs%i
+     end select
+     select type (rhs)
+       type is (i_field); m = rhs%i + m
+     end select
+     allocate (i_plus_i, source = i_field (m))
+   end function
+   function i_multiply_real(lhs,rhs)
+     class(i_field) ,intent(in)  :: lhs
+     real ,intent(in) :: rhs
+     class(field) ,allocatable :: i_multiply_real
+     integer :: m = 0
+     select type (lhs)
+       type is (i_field); m = lhs%i * int (rhs)
+     end select
+     allocate (i_multiply_real, source = i_field (m))
+   end function
+   subroutine i_assn(lhs,rhs)
+     class(i_field) ,intent(OUT)  :: lhs
+     class(field) ,intent(IN)  :: rhs
+     select type (lhs)
+       type is (i_field)
+         select type (rhs)
+           type is (i_field)
+             lhs%i = rhs%i
+         end select         
+       end select
+     end subroutine
+ end module
+ 
+ program main
+   use i_field_module
+   implicit none
+   class(i_field) ,allocatable :: u
+   allocate (u, source = i_field (99))
+ 
+   u = u*2.
+   u = (u*2.0*4.0) + u*4.0
+   u = u%multiply_real (2.0)*4.0
+   u = i_multiply_real (u, 2.0) * 4.0
+   
+   select type (u)
+     type is (i_field); if (u%i .ne. 152064) call abort
+   end select
+ end program
+ ! { dg-final { cleanup-modules "field_module i_field_module" } }
+