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

@@ -1,3 +1,33 @@
+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

@@ -1,6 +1,6 @@
 /* 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

@@ -1,6 +1,6 @@
 /* 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

@@ -1,6 +1,6 @@
 /* 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
+      if ((ref->u.c.component->ts.type == BT_CLASS
-	    || ref->u.c.component->ts.type == BT_DERIVED)
+	     || (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

@@ -1,6 +1,6 @@
 /* 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/fortran/trans-expr.c

@@ -1,6 +1,6 @@
 /* Expression translation
    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>
@@ -302,6 +302,179 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
   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,6 +2149,31 @@ get_proc_ptr_comp (gfc_expr *e)
 }
 
 
+/* 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,6 +3282,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   tree type;
   tree var;
   tree len;
+  tree base_object;
   VEC(tree,gc) *stringargs;
   tree result = NULL;
   gfc_formal_arglist *formal;
@@ -3156,6 +3355,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				   != EXPR_CONSTANT);
     }
 
+  base_object = NULL_TREE;
+
   /* Evaluate the arguments.  */
   for (arg = args; arg != NULL;
        arg = arg->next, formal = formal ? formal->next : NULL)
@@ -3301,6 +3502,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		{
 		  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,7 +4208,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
   arglist = retargs;
 
   /* Generate the actual call.  */
-  conv_function_val (se, sym, expr);
+  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,7 +5505,6 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
       return;
     }
 
-
   gfc_conv_expr (se, expr);
 
   /* Create a temporary var to hold the value.  */
@@ -6730,158 +6940,3 @@ gfc_trans_assign (gfc_code * code)
 {
   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);
-}

gcc/testsuite/ChangeLog

@@ -1,3 +1,11 @@
+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

@@ -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" } }
+

gcc/testsuite/gfortran.dg/typebound_operator_8.f03

@@ -0,0 +1,499 @@
+! { dg-do run }
+!
+!     Solve a diffusion problem using an object-oriented approach
+!
+!     Author: Arjen Markus (comp.lang.fortran)
+!     This version: pault@gcc.gnu.org
+!
+!     Note:
+!     (i) This could be turned into a more sophisticated program
+!     using the techniques described in the chapter on
+!     mathematical abstractions.
+!     (That would allow the selection of the time integration
+!     method in a transparent way)
+!
+!     (ii) The target procedures for process_p and source_p are
+!     different to the typebound procedures for dynamic types
+!     because the passed argument is not type(base_pde_object).
+!
+!     (iii) Two solutions are calculated, one with the procedure
+!     pointers and the other with typebound procedures. The sums
+!     of the solutions are compared.
+
+!     (iv) The source is a delta function in the middle of the
+!     mesh, whilst the process is quartic in the local value,
+!     when it is positive.
+!
+! base_pde_objects --
+!     Module to define the basic objects
+!
+module base_pde_objects
+  implicit none
+  type, abstract :: base_pde_object
+! No data
+    procedure(process_p), pointer, pass :: process_p
+    procedure(source_p), pointer, pass  :: source_p
+  contains
+    procedure(process), deferred :: process
+    procedure(source), deferred :: source
+    procedure :: initialise
+    procedure :: nabla2
+    procedure :: print
+    procedure(real_times_obj), pass(obj), deferred :: real_times_obj
+    procedure(obj_plus_obj),              deferred :: obj_plus_obj
+    procedure(obj_assign_obj),            deferred :: obj_assign_obj
+    generic :: operator(*)    => real_times_obj
+    generic :: operator(+)    => obj_plus_obj
+    generic :: assignment(=)  => obj_assign_obj
+  end type
+  abstract interface
+    function process_p (obj)
+      import base_pde_object
+      class(base_pde_object), intent(in)  :: obj
+      class(base_pde_object), allocatable :: process_p
+    end function process_p
+  end interface
+  abstract interface
+    function source_p (obj, time)
+      import base_pde_object
+      class(base_pde_object), intent(in)  :: obj
+      real, intent(in)                    :: time
+      class(base_pde_object), allocatable :: source_p
+    end function source_p
+  end interface
+  abstract interface
+    function process (obj)
+      import base_pde_object
+      class(base_pde_object), intent(in)  :: obj
+      class(base_pde_object), allocatable :: process
+    end function process
+  end interface
+  abstract interface
+    function source (obj, time)
+      import base_pde_object
+      class(base_pde_object), intent(in)  :: obj
+      real, intent(in)                    :: time
+      class(base_pde_object), allocatable :: source
+    end function source
+  end interface
+  abstract interface
+    function real_times_obj (factor, obj) result(newobj)
+      import base_pde_object
+      real, intent(in)                    :: factor
+      class(base_pde_object), intent(in)  :: obj
+      class(base_pde_object), allocatable :: newobj
+    end function real_times_obj
+  end interface
+  abstract interface
+    function obj_plus_obj (obj1, obj2) result(newobj)
+      import base_pde_object
+      class(base_pde_object), intent(in)  :: obj1
+      class(base_pde_object), intent(in)  :: obj2
+      class(base_pde_object), allocatable :: newobj
+    end function obj_plus_obj
+  end interface
+  abstract interface
+    subroutine obj_assign_obj (obj1, obj2)
+      import base_pde_object
+      class(base_pde_object), intent(inout)  :: obj1
+      class(base_pde_object), intent(in)     :: obj2
+    end subroutine obj_assign_obj
+  end interface
+contains
+! print --
+!     Print the concentration field
+  subroutine print (obj)
+    class(base_pde_object) :: obj
+    ! Dummy
+  end subroutine print
+! initialise --
+!     Initialise the concentration field using a specific function
+  subroutine initialise (obj, funcxy)
+    class(base_pde_object) :: obj
+    interface
+      real function funcxy (coords)
+        real, dimension(:), intent(in) :: coords
+      end function funcxy
+    end interface
+    ! Dummy
+  end subroutine initialise
+! nabla2 --
+!     Determine the divergence
+  function nabla2 (obj)
+    class(base_pde_object), intent(in)  :: obj
+    class(base_pde_object), allocatable :: nabla2
+    ! Dummy
+  end function nabla2
+end module base_pde_objects
+! cartesian_2d_objects --
+!     PDE object on a 2D cartesian grid
+!
+module cartesian_2d_objects
+  use base_pde_objects
+  implicit none
+  type, extends(base_pde_object) :: cartesian_2d_object
+    real, dimension(:,:), allocatable :: c
+    real                              :: dx
+    real                              :: dy
+  contains
+    procedure            :: process       => process_cart2d
+    procedure            :: source         => source_cart2d
+    procedure            :: initialise     => initialise_cart2d
+    procedure            :: nabla2         => nabla2_cart2d
+    procedure            :: print          => print_cart2d
+    procedure, pass(obj) :: real_times_obj => real_times_cart2d
+    procedure            :: obj_plus_obj   => obj_plus_cart2d
+    procedure            :: obj_assign_obj => obj_assign_cart2d
+  end type cartesian_2d_object
+  interface grid_definition
+    module procedure grid_definition_cart2d
+  end interface
+contains
+  function process_cart2d (obj)
+    class(cartesian_2d_object), intent(in)  :: obj
+    class(base_pde_object), allocatable :: process_cart2d
+    allocate (process_cart2d,source = obj)
+    select type (process_cart2d)
+      type is (cartesian_2d_object)
+        process_cart2d%c = -sign (obj%c, 1.0)*obj%c** 4
+      class default
+        call abort
+    end select
+  end function process_cart2d
+  function process_cart2d_p (obj)
+    class(base_pde_object), intent(in)  :: obj
+    class(base_pde_object), allocatable :: process_cart2d_p
+    allocate (process_cart2d_p,source = obj)
+    select type (process_cart2d_p)
+      type is (cartesian_2d_object)
+        select type (obj)
+          type is (cartesian_2d_object)
+            process_cart2d_p%c = -sign (obj%c, 1.0)*obj%c** 4
+        end select
+      class default
+        call abort
+    end select
+  end function process_cart2d_p
+  function source_cart2d (obj, time)
+    class(cartesian_2d_object), intent(in)  :: obj
+    real, intent(in)                    :: time
+    class(base_pde_object), allocatable :: source_cart2d
+    integer :: m, n
+    m = size (obj%c, 1)
+    n = size (obj%c, 2)
+    allocate (source_cart2d, source = obj)
+    select type (source_cart2d)
+      type is (cartesian_2d_object)
+        if (allocated (source_cart2d%c)) deallocate (source_cart2d%c)
+        allocate (source_cart2d%c(m, n))
+        source_cart2d%c = 0.0
+        if (time .lt. 5.0) source_cart2d%c(m/2, n/2) = 0.1
+      class default
+        call abort
+    end select
+  end function source_cart2d
+
+  function source_cart2d_p (obj, time)
+    class(base_pde_object), intent(in)  :: obj
+    real, intent(in)                    :: time
+    class(base_pde_object), allocatable :: source_cart2d_p
+    integer :: m, n
+    select type (obj)
+      type is (cartesian_2d_object)
+        m = size (obj%c, 1)
+        n = size (obj%c, 2)
+      class default
+       call abort
+    end select
+    allocate (source_cart2d_p,source = obj)
+    select type (source_cart2d_p)
+      type is (cartesian_2d_object)
+        if (allocated (source_cart2d_p%c)) deallocate (source_cart2d_p%c)
+        allocate (source_cart2d_p%c(m,n))
+        source_cart2d_p%c = 0.0
+        if (time .lt. 5.0) source_cart2d_p%c(m/2, n/2) = 0.1
+      class default
+        call abort
+    end select
+  end function source_cart2d_p
+
+! grid_definition --
+!     Initialises the grid
+!
+  subroutine grid_definition_cart2d (obj, sizes, dims)
+    class(base_pde_object), allocatable :: obj
+    real, dimension(:)                  :: sizes
+    integer, dimension(:)               :: dims
+    allocate( cartesian_2d_object :: obj )
+    select type (obj)
+      type is (cartesian_2d_object)
+        allocate (obj%c(dims(1), dims(2)))
+        obj%c  = 0.0
+        obj%dx = sizes(1)/dims(1)
+        obj%dy = sizes(2)/dims(2)
+      class default
+        call abort
+    end select
+  end subroutine grid_definition_cart2d
+! print_cart2d --
+!     Print the concentration field to the screen
+!
+  subroutine print_cart2d (obj)
+    class(cartesian_2d_object) :: obj
+    character(len=20)          :: format
+    write( format, '(a,i0,a)' ) '(', size(obj%c,1), 'f6.3)'
+    write( *, format ) obj%c
+  end subroutine print_cart2d
+! initialise_cart2d --
+!     Initialise the concentration field using a specific function
+!
+  subroutine initialise_cart2d (obj, funcxy)
+    class(cartesian_2d_object) :: obj
+    interface
+      real function funcxy (coords)
+        real, dimension(:), intent(in) :: coords
+      end function funcxy
+    end interface
+    integer                    :: i, j
+    real, dimension(2)         :: x
+    obj%c = 0.0
+    do j = 2,size (obj%c, 2)-1
+      x(2) = obj%dy * (j-1)
+      do i = 2,size (obj%c, 1)-1
+        x(1) = obj%dx * (i-1)
+        obj%c(i,j) = funcxy (x)
+      enddo
+    enddo
+  end subroutine initialise_cart2d
+! nabla2_cart2d
+!     Determine the divergence
+  function nabla2_cart2d (obj)
+    class(cartesian_2d_object), intent(in)  :: obj
+    class(base_pde_object), allocatable     :: nabla2_cart2d
+    integer                                 :: m, n
+    real                                    :: dx, dy
+    m = size (obj%c, 1)
+    n = size (obj%c, 2)
+    dx = obj%dx
+    dy = obj%dy
+    allocate (cartesian_2d_object :: nabla2_cart2d)
+    select type (nabla2_cart2d)
+      type is (cartesian_2d_object)
+        allocate (nabla2_cart2d%c(m,n))
+        nabla2_cart2d%c = 0.0
+        nabla2_cart2d%c(2:m-1,2:n-1) = &
+          -(2.0 * obj%c(2:m-1,2:n-1) - obj%c(1:m-2,2:n-1) - obj%c(3:m,2:n-1)) / dx**2 &
+          -(2.0 * obj%c(2:m-1,2:n-1) - obj%c(2:m-1,1:n-2) - obj%c(2:m-1,3:n)) / dy**2
+      class default
+        call abort
+    end select
+  end function nabla2_cart2d
+  function real_times_cart2d (factor, obj) result(newobj)
+    real, intent(in)                        :: factor
+    class(cartesian_2d_object), intent(in)  :: obj
+    class(base_pde_object), allocatable     :: newobj
+    integer                                 :: m, n
+    m = size (obj%c, 1)
+    n = size (obj%c, 2)
+    allocate (cartesian_2d_object :: newobj)
+    select type (newobj)
+      type is (cartesian_2d_object)
+        allocate (newobj%c(m,n))
+        newobj%c = factor * obj%c
+      class default
+        call abort
+    end select
+  end function real_times_cart2d
+  function obj_plus_cart2d (obj1, obj2) result( newobj )
+    class(cartesian_2d_object), intent(in)  :: obj1
+    class(base_pde_object), intent(in)      :: obj2
+    class(base_pde_object), allocatable     :: newobj
+    integer                                 :: m, n
+    m = size (obj1%c, 1)
+    n = size (obj1%c, 2)
+    allocate (cartesian_2d_object :: newobj)
+    select type (newobj)
+      type is (cartesian_2d_object)
+        allocate (newobj%c(m,n))
+          select type (obj2)
+            type is (cartesian_2d_object)
+              newobj%c = obj1%c + obj2%c
+            class default
+              call abort
+          end select
+      class default
+        call abort
+    end select
+  end function obj_plus_cart2d
+  subroutine obj_assign_cart2d (obj1, obj2)
+    class(cartesian_2d_object), intent(inout) :: obj1
+    class(base_pde_object), intent(in)        :: obj2
+    select type (obj2)
+      type is (cartesian_2d_object)
+        obj1%c = obj2%c
+      class default
+        call abort
+    end select
+  end subroutine obj_assign_cart2d
+end module cartesian_2d_objects
+! define_pde_objects --
+!     Module to bring all the PDE object types together
+!
+module define_pde_objects
+  use base_pde_objects
+  use cartesian_2d_objects
+  implicit none
+  interface grid_definition
+    module procedure grid_definition_general
+  end interface
+contains
+  subroutine grid_definition_general (obj, type, sizes, dims)
+    class(base_pde_object), allocatable :: obj
+    character(len=*)                    :: type
+    real, dimension(:)                  :: sizes
+    integer, dimension(:)               :: dims
+    select case (type)
+      case ("cartesian 2d")
+        call grid_definition (obj, sizes, dims)
+      case default
+        write(*,*) 'Unknown grid type: ', trim (type)
+        stop
+    end select
+  end subroutine grid_definition_general
+end module define_pde_objects
+! pde_specific --
+!     Module holding the routines specific to the PDE that
+!     we are solving
+!
+module pde_specific
+  implicit none
+contains
+  real function patch (coords)
+    real, dimension(:), intent(in) :: coords
+    if (sum ((coords-[50.0,50.0])**2) < 40.0) then
+      patch = 1.0
+    else
+      patch = 0.0
+    endif
+  end function patch
+end module pde_specific
+! test_pde_solver --
+!     Small test program to demonstrate the usage
+!
+program test_pde_solver
+  use define_pde_objects
+  use pde_specific
+  implicit none
+  class(base_pde_object), allocatable :: solution, deriv
+  integer                             :: i
+  real                                :: time, dtime, diff, chksum(2)
+
+  call simulation1     ! Use proc pointers for source and process define_pde_objects
+  select type (solution)
+    type is (cartesian_2d_object)
+      deallocate (solution%c)
+  end select
+  select type (deriv)
+    type is (cartesian_2d_object)
+      deallocate (deriv%c)
+  end select
+  deallocate (solution, deriv)
+
+  call simulation2     ! Use typebound procedures for source and process
+  if (chksum(1) .ne. chksum(2)) call abort
+  if ((chksum(1) - 0.881868720)**2 > 1e-4) call abort
+contains
+  subroutine simulation1
+!
+! Create the grid
+!
+    call grid_definition (solution, "cartesian 2d", [100.0, 100.0], [16, 16])
+    call grid_definition (deriv,    "cartesian 2d", [100.0, 100.0], [16, 16])
+!
+! Initialise the concentration field
+!
+    call solution%initialise (patch)
+!
+! Set the procedure pointers
+!
+    solution%source_p => source_cart2d_p
+    solution%process_p => process_cart2d_p
+!
+! Perform the integration - explicit method
+!
+    time  = 0.0
+    dtime = 0.1
+    diff =  5.0e-3
+
+! Give the diffusion coefficient correct dimensions.
+    select type (solution)
+      type is (cartesian_2d_object)
+        diff  = diff * solution%dx * solution%dy / dtime
+    end select
+
+!     write(*,*) 'Time: ', time, diff
+!     call solution%print
+    do i = 1,100
+      deriv    =  solution%nabla2 ()
+      solution = solution + diff * dtime * deriv + solution%source_p (time) + solution%process_p ()
+!         if ( mod(i, 25) == 0 ) then
+!             write(*,*)'Time: ', time
+!             call solution%print
+!         endif
+    time = time + dtime
+    enddo
+!    write(*,*) 'End result 1: '
+!    call solution%print
+    select type (solution)
+      type is (cartesian_2d_object)
+        chksum(1) = sum (solution%c)
+    end select
+  end subroutine
+  subroutine simulation2
+!
+! Create the grid
+!
+    call grid_definition (solution, "cartesian 2d", [100.0, 100.0], [16, 16])
+    call grid_definition (deriv,    "cartesian 2d", [100.0, 100.0], [16, 16])
+!
+! Initialise the concentration field
+!
+    call solution%initialise (patch)
+!
+! Set the procedure pointers
+!
+    solution%source_p => source_cart2d_p
+    solution%process_p => process_cart2d_p
+!
+! Perform the integration - explicit method
+!
+    time  = 0.0
+    dtime = 0.1
+    diff =  5.0e-3
+
+! Give the diffusion coefficient correct dimensions.
+    select type (solution)
+      type is (cartesian_2d_object)
+        diff  = diff * solution%dx * solution%dy / dtime
+    end select
+
+!     write(*,*) 'Time: ', time, diff
+!     call solution%print
+    do i = 1,100
+      deriv    =  solution%nabla2 ()
+      solution = solution + diff * dtime * deriv + solution%source (time) + solution%process ()
+!         if ( mod(i, 25) == 0 ) then
+!             write(*,*)'Time: ', time
+!             call solution%print
+!         endif
+      time = time + dtime
+    enddo
+!    write(*,*) 'End result 2: '
+!    call solution%print
+    select type (solution)
+      type is (cartesian_2d_object)
+        chksum(2) = sum (solution%c)
+    end select
+  end subroutine
+end program test_pde_solver
+! { dg-final { cleanup-modules "pde_specific define_pde_objects cartesian_2d_objects base_pde_objects" } }