re PR fortran/43207 ([OOP] invalid (pointer) assignment to and from abstract…

re PR fortran/43207 ([OOP] invalid (pointer) assignment to and from abstract non-polymorphic expressions)

2010-05-15  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/43207
	PR fortran/43969
	* gfortran.h (gfc_class_null_initializer): New prototype.
	* expr.c (gfc_class_null_initializer): New function to build a NULL
	initializer for CLASS pointers.
	* symbol.c (gfc_build_class_symbol): Modify internal naming of class
	containers. Remove default NULL initialization of $data component.
	* trans.c (gfc_allocate_array_with_status): Fix wording of an error 
	message.
	* trans-expr.c (gfc_conv_initializer,gfc_trans_subcomponent_assign):
	Use new function 'gfc_class_null_initializer'.
	* trans-intrinsic.c (gfc_conv_allocated): Handle allocatable scalar
	class variables.


2010-05-15  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/43207
	PR fortran/43969
	* gfortran.dg/class_18.f03: New.
	* gfortran.dg/class_19.f03: New.

From-SVN: r159431

gcc/fortran/ChangeLog

+2010-05-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/43207
+	PR fortran/43969
+	* gfortran.h (gfc_class_null_initializer): New prototype.
+	* expr.c (gfc_class_null_initializer): New function to build a NULL
+	initializer for CLASS pointers.
+	* symbol.c (gfc_build_class_symbol): Modify internal naming of class
+	containers. Remove default NULL initialization of $data component.
+	* trans.c (gfc_allocate_array_with_status): Fix wording of an error 
+	message.
+	* trans-expr.c (gfc_conv_initializer,gfc_trans_subcomponent_assign):
+	Use new function 'gfc_class_null_initializer'.
+	* trans-intrinsic.c (gfc_conv_allocated): Handle allocatable scalar
+	class variables.
+
 2010-05-14  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/44135

gcc/fortran/expr.c

@@ -3628,6 +3628,32 @@ gfc_default_initializer (gfc_typespec *ts)
 }
 
 
+/* Build a NULL initializer for CLASS pointers,
+   initializing the $data and $vptr components to zero.  */
+
+gfc_expr *
+gfc_class_null_initializer (gfc_typespec *ts)
+{
+  gfc_expr *init;
+  gfc_component *comp;
+  
+  init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
+					     &ts->u.derived->declared_at);
+  init->ts = *ts;
+  
+  for (comp = ts->u.derived->components; comp; comp = comp->next)
+    {
+      gfc_constructor *ctor = gfc_constructor_get();
+      ctor->expr = gfc_get_expr ();
+      ctor->expr->expr_type = EXPR_NULL;
+      ctor->expr->ts = comp->ts;
+      gfc_constructor_append (&init->value.constructor, ctor);
+    }
+
+  return init;
+}
+
+
 /* Given a symbol, create an expression node with that symbol as a
    variable. If the symbol is array valued, setup a reference of the
    whole array.  */

gcc/fortran/gfortran.h

@@ -2630,6 +2630,7 @@ gfc_try gfc_check_pointer_assign (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *);
 
 gfc_expr *gfc_default_initializer (gfc_typespec *);
+gfc_expr *gfc_class_null_initializer (gfc_typespec *);
 gfc_expr *gfc_get_variable_expr (gfc_symtree *);
 
 gfc_array_spec *gfc_get_full_arrayspec_from_expr (gfc_expr *expr);

gcc/fortran/symbol.c

@@ -4717,15 +4717,15 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
 
   /* Determine the name of the encapsulating type.  */
   if ((*as) && (*as)->rank && attr->allocatable)
-    sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
+    sprintf (name, "class$%s_%d_a", ts->u.derived->name, (*as)->rank);
   else if ((*as) && (*as)->rank)
-    sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank);
+    sprintf (name, "class$%s_%d", ts->u.derived->name, (*as)->rank);
   else if (attr->pointer)
-    sprintf (name, ".class.%s.p", ts->u.derived->name);
+    sprintf (name, "class$%s_p", ts->u.derived->name);
   else if (attr->allocatable)
-    sprintf (name, ".class.%s.a", ts->u.derived->name);
+    sprintf (name, "class$%s_a", ts->u.derived->name);
   else
-    sprintf (name, ".class.%s", ts->u.derived->name);
+    sprintf (name, "class$%s", ts->u.derived->name);
 
   gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
   if (fclass == NULL)
@@ -4759,7 +4759,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       c->attr.codimension = attr->codimension;
       c->attr.abstract = ts->u.derived->attr.abstract;
       c->as = (*as);
-      c->initializer = gfc_get_null_expr (NULL);
+      c->initializer = NULL;
 
       /* Add component '$vptr'.  */
       if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)

gcc/fortran/trans-expr.c

@@ -3894,7 +3894,10 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
 	case BT_DERIVED:
 	case BT_CLASS:
 	  gfc_init_se (&se, NULL);
-	  gfc_conv_structure (&se, expr, 1);
+	  if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
+	    gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
+	  else
+	    gfc_conv_structure (&se, expr, 1);
 	  return se.expr;
 
 	case BT_CHARACTER:
@@ -4202,7 +4205,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
     {
       /* NULL initialization for CLASS components.  */
       tmp = gfc_trans_structure_assign (dest,
-					gfc_default_initializer (&cm->ts));
+					gfc_class_null_initializer (&cm->ts));
       gfc_add_expr_to_block (&block, tmp);
     }
   else if (cm->attr.dimension)

gcc/fortran/trans-intrinsic.c

@@ -4529,6 +4529,8 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
     {
       /* Allocatable scalar.  */
       arg1se.want_pointer = 1;
+      if (arg1->expr->ts.type == BT_CLASS)
+	gfc_add_component_ref (arg1->expr, "$data");
       gfc_conv_expr (&arg1se, arg1->expr);
       tmp = arg1se.expr;
     }

gcc/fortran/trans.c

@@ -704,7 +704,7 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
 	  return mem;
 	}
 	else
-	  runtime_error ("Attempting to allocate already allocated array");
+	  runtime_error ("Attempting to allocate already allocated variable");
       }
     }
     
@@ -743,13 +743,13 @@ gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
 
       error = gfc_trans_runtime_error (true, &expr->where,
 				       "Attempting to allocate already"
-				       " allocated array '%s'",
+				       " allocated variable '%s'",
 				       varname);
     }
   else
     error = gfc_trans_runtime_error (true, NULL,
 				     "Attempting to allocate already allocated"
-				     "array");
+				     "variable");
 
   if (status != NULL_TREE && !integer_zerop (status))
     {

gcc/testsuite/ChangeLog

+2010-05-15  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/43207
+	PR fortran/43969
+	* gfortran.dg/class_18.f03: New.
+	* gfortran.dg/class_19.f03: New.
+
 2010-05-14  Jakub Jelinek  <jakub@redhat.com>
 
 	PR debug/44112

gcc/testsuite/gfortran.dg/class_18.f03

+! { dg-do run }
+!
+! PR 43207: [OOP] ICE for class pointer => null() initialization
+!
+! Original test case by Tobias Burnus <burnus@gcc.gnu.org>
+! Modified by Janus Weil <janus@gcc.gnu.org>
+
+  implicit none
+  type :: parent
+  end type
+  type(parent), target :: t
+  class(parent), pointer :: cp => null()
+
+  if (associated(cp)) call abort()
+  cp => t
+  if (.not. associated(cp)) call abort()
+
+end

gcc/testsuite/gfortran.dg/class_19.f03

+! { dg-do run }
+!
+! PR 43969: [OOP] ALLOCATED() with polymorphic variables
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+
+
+module foo_mod
+  type foo_inner
+    integer, allocatable :: v(:)
+  end type foo_inner
+  type foo_outer
+    class(foo_inner), allocatable :: int
+  end type foo_outer
+contains
+subroutine foo_checkit()
+  implicit none
+  type(foo_outer)    :: try
+  type(foo_outer),allocatable :: try2
+  class(foo_outer), allocatable :: try3
+  
+  if (allocated(try%int)) call abort()
+  allocate(foo_outer :: try3)
+  if (allocated(try3%int)) call abort()
+  allocate(try2)
+  if (allocated(try2%int)) call abort()
+ 
+end subroutine foo_checkit
+end module foo_mod
+
+
+program main
+
+  use foo_mod
+  implicit none
+  
+  call foo_checkit()
+
+end program main
+
+! { dg-final { cleanup-modules "foo_mod" } }