re PR fortran/51529 ([OOP] gfortran.dg/class_to_type_1.f03 is miscompiled:…

re PR fortran/51529 ([OOP] gfortran.dg/class_to_type_1.f03 is miscompiled: Uninitialized variable used)

2012-01-02  Paul Thomas  <pault@gcc.gnu.org>

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

	PR fortran/46262
	PR fortran/46328
	PR fortran/51052
	* 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.
	(gfc_trans_class_array_init_assign, gfc_trans_class_init_assign
	gfc_trans_class_assign): Move to top of file.
	* 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.


2012-01-02  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/46262
	PR fortran/46328
	PR fortran/51052
	* gfortran.dg/typebound_operator_7.f03: New.
	* gfortran.dg/typebound_operator_8.f03: New.

From-SVN: r182796

gcc/fortran/ChangeLog

+2012-01-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/51529
+	* trans-array.c (gfc_array_allocate): Null allocated memory of
+	newly allocted class arrays.
+
+	PR fortran/46262
+	PR fortran/46328
+	PR fortran/51052
+	* 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.
+	(gfc_trans_class_array_init_assign, gfc_trans_class_init_assign
+	gfc_trans_class_assign): Move to top of file.
+	* 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.
+
 2012-01-02  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/51682

gcc/fortran/dump-parse-tree.c

@@ -2330,3 +2330,4 @@ gfc_dump_parse_tree (gfc_namespace *ns, FILE *file)
   dumpfile = file;
   show_namespace (ns);
 }
+

gcc/fortran/gfortran.h

 /* gfortran header file
    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-   2009, 2010, 2011
+   2009, 2010, 2011, 2012
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
@@ -1697,6 +1697,10 @@ typedef struct gfc_expr
 
   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;

gcc/fortran/interface.c

 /* Deal with interfaces.
    Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009,
-   2010
+   2010, 2011, 2012
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
@@ -3256,6 +3256,14 @@ build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
   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;
+    }
 }
 
 

gcc/fortran/resolve.c

 /* Perform type resolution on the various structures.
    Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
-   2010, 2011
+   2010, 2011, 2012
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
@@ -5620,10 +5620,11 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
 
 /* Get the ultimate declared type from an expression.  In addition,
    return the last class/derived type reference and the copy of the
-   reference list.  */
+   reference list.  If check_types is set true, derived types are
+   identified as well as class references.  */
 static gfc_symbol*
 get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
-			gfc_expr *e)
+			gfc_expr *e, bool check_types)
 {
   gfc_symbol *declared;
   gfc_ref *ref;
@@ -5639,8 +5640,9 @@ get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
       if (ref->type != REF_COMPONENT)
 	continue;
 
-      if (ref->u.c.component->ts.type == BT_CLASS
-	    || ref->u.c.component->ts.type == BT_DERIVED)
+      if ((ref->u.c.component->ts.type == BT_CLASS
+	     || (check_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,7 +5737,7 @@ resolve_typebound_generic_call (gfc_expr* e, const char **name)
 
 success:
   /* Make sure that we have the right specific instance for the name.  */
-  derived = get_declared_from_expr (NULL, NULL, e);
+  derived = get_declared_from_expr (NULL, NULL, e, true);
 
   st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where);
   if (st)
@@ -5852,7 +5854,7 @@ resolve_compcall (gfc_expr* e, const char **name)
 /* Resolve a typebound function, or 'method'. First separate all
    the non-CLASS references by calling resolve_compcall directly.  */
 
-static gfc_try
+gfc_try
 resolve_typebound_function (gfc_expr* e)
 {
   gfc_symbol *declared;
@@ -5872,6 +5874,21 @@ resolve_typebound_function (gfc_expr* e)
   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,9 +5905,26 @@ resolve_typebound_function (gfc_expr* e)
       name = name ? name : e->value.function.esym->name;
       e->symtree = expr->symtree;
       e->ref = gfc_copy_ref (expr->ref);
+      get_declared_from_expr (&class_ref, NULL, e, false);
+
+      /* Trim away the extraneous references that emerge from nested
+	 use of interface.c (extend_expr).  */
+      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;
+	}
+
       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,7 +5935,7 @@ resolve_typebound_function (gfc_expr* e)
     return FAILURE;
 
   /* Get the CLASS declared type.  */
-  declared = get_declared_from_expr (&class_ref, &new_ref, e);
+  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,6 +6001,20 @@ resolve_typebound_subroutine (gfc_code *code)
   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,9 +6030,27 @@ resolve_typebound_subroutine (gfc_code *code)
       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,7 +6061,7 @@ resolve_typebound_subroutine (gfc_code *code)
     return FAILURE;
 
   /* Get the CLASS declared type.  */
-  get_declared_from_expr (&class_ref, &new_ref, code->expr1);
+  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)

gcc/fortran/trans-array.c

 /* Array translation routines
    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-   2011
+   2011, 2012
    Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
    and Steven Bosscher <s.bosscher@student.tudelft.nl>
@@ -5069,6 +5069,18 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 
   gfc_add_expr_to_block (&se->pre, tmp);
 
+  if (expr->ts.type == BT_CLASS && expr3)
+    {
+      tmp = build_int_cst (unsigned_char_type_node, 0);
+      /* 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.  */
+      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);

gcc/testsuite/ChangeLog

+2012-01-02  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/46262
+	PR fortran/46328
+	PR fortran/51052
+	* gfortran.dg/typebound_operator_7.f03: New.
+	* gfortran.dg/typebound_operator_8.f03: New.
+
 2012-01-02  Richard Sandiford  <rdsandiford@googlemail.com>
 
 	PR target/51729

gcc/testsuite/gfortran.dg/typebound_operator_7.f03

+! { 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" } }
+