re PR fortran/51970 ([OOP] gimplification failed for polymorphic MOVE_ALLOC)

2012-01-27  Tobias Burnus  <burnus@net-b.de>

        PR fortran/51970
        PR fortran/51977
        * primary.c (gfc_match_varspec. gfc_match_rvalue): Set
        handle array spec for BT_CLASS.
        * expr.c (gfc_get_variable_expr, gfc_lval_expr_from_sym)
        * frontend-passes.c (create_var): Ditto.
        * resolve.c (resolve_actual_arglist, resolve_assoc_var): Ditto.
        * trans-decl.c (gfc_trans_deferred_vars): Use class_pointer
        instead of attr.pointer.
        (gfc_generate_function_code): Use CLASS_DATA (sym) for BT_CLASS.
        * trans-intrinsic.c (conv_intrinsic_move_alloc): Move assert.
        * trans-stmt.c (trans_associate_var): Ask for the descriptor.

2012-01-27  Tobias Burnus  <burnus@net-b.de>

        PR fortran/51970
        PR fortran/51977
        * gfortran.dg/move_alloc_13.f90: New.

From-SVN: r183622

gcc/fortran/ChangeLog

@@ -1,3 +1,18 @@
+2012-01-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51970
+	PR fortran/51977
+	* primary.c (gfc_match_varspec. gfc_match_rvalue): Set
+	handle array spec for BT_CLASS.
+	* expr.c (gfc_get_variable_expr, gfc_lval_expr_from_sym)
+	* frontend-passes.c (create_var): Ditto.
+	* resolve.c (resolve_actual_arglist, resolve_assoc_var): Ditto.
+	* trans-decl.c (gfc_trans_deferred_vars): Use class_pointer
+	instead of attr.pointer.
+	(gfc_generate_function_code): Use CLASS_DATA (sym) for BT_CLASS.
+	* trans-intrinsic.c (conv_intrinsic_move_alloc): Move assert.
+	* trans-stmt.c (trans_associate_var): Ask for the descriptor.
+
 2012-01-27  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/51953

gcc/fortran/expr.c

@@ -3805,9 +3805,12 @@ gfc_get_variable_expr (gfc_symtree *var)
   e->symtree = var;
   e->ts = var->n.sym->ts;
 
-  if (var->n.sym->as != NULL)
+  if ((var->n.sym->as != NULL && var->n.sym->ts.type != BT_CLASS)
+      || (var->n.sym->ts.type == BT_CLASS && CLASS_DATA (var->n.sym)
+	  && CLASS_DATA (var->n.sym)->as))
     {
-      e->rank = var->n.sym->as->rank;
+      e->rank = var->n.sym->ts.type == BT_CLASS
+		? CLASS_DATA (var->n.sym)->as->rank : var->n.sym->as->rank;
       e->ref = gfc_get_ref ();
       e->ref->type = REF_ARRAY;
       e->ref->u.ar.type = AR_FULL;
@@ -3836,7 +3839,8 @@ gfc_lval_expr_from_sym (gfc_symbol *sym)
       lval->ref->u.ar.type = AR_FULL;
       lval->ref->u.ar.dimen = lval->rank;
       lval->ref->u.ar.where = sym->declared_at;
-      lval->ref->u.ar.as = sym->as;
+      lval->ref->u.ar.as = sym->ts.type == BT_CLASS
+			   ? CLASS_DATA (sym)->as : sym->as;
     }
 
   return lval;

gcc/fortran/frontend-passes.c

@@ -328,7 +328,8 @@ create_var (gfc_expr * e)
       result->ref->type = REF_ARRAY;
       result->ref->u.ar.type = AR_FULL;
       result->ref->u.ar.where = e->where;
-      result->ref->u.ar.as = symbol->as;
+      result->ref->u.ar.as = symbol->ts.type == BT_CLASS
+			     ? CLASS_DATA (symbol)->as : symbol->as;
       if (gfc_option.warn_array_temp)
 	gfc_warning ("Creating array temporary at %L", &(e->where));
     }

gcc/fortran/primary.c

@@ -1868,18 +1868,24 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	  && (CLASS_DATA (sym)->attr.dimension
 	      || CLASS_DATA (sym)->attr.codimension)))
     {
-      /* In EQUIVALENCE, we don't know yet whether we are seeing
+      gfc_array_spec *as;
-	 an array, character variable or array of character
+
-	 variables.  We'll leave the decision till resolve time.  */
       tail = extend_ref (primary, tail);
       tail->type = REF_ARRAY;
 
-      m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
+      /* In EQUIVALENCE, we don't know yet whether we are seeing
-			       equiv_flag,
+	 an array, character variable or array of character
-			       sym->ts.type == BT_CLASS && CLASS_DATA (sym)
+	 variables.  We'll leave the decision till resolve time.  */
-			       ? (CLASS_DATA (sym)->as
+
-				  ? CLASS_DATA (sym)->as->corank : 0)
+      if (equiv_flag)
-			       : (sym->as ? sym->as->corank : 0));
+	as = NULL;
+      else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
+	as = CLASS_DATA (sym)->as;
+      else
+	as = sym->as;
+
+      m = gfc_match_array_ref (&tail->u.ar, as, equiv_flag,
+			       as ? as->corank : 0);
       if (m != MATCH_YES)
 	return m;
 
@@ -2893,7 +2899,10 @@ gfc_match_rvalue (gfc_expr **result)
       e->value.function.actual = actual_arglist;
       e->where = gfc_current_locus;
 
-      if (sym->as != NULL)
+      if (sym->ts.type == BT_CLASS && sym->attr.class_ok
+	  && CLASS_DATA (sym)->as)
+	e->rank = CLASS_DATA (sym)->as->rank;
+      else if (sym->as != NULL)
 	e->rank = sym->as->rank;
 
       if (!sym->attr.function

gcc/fortran/resolve.c

@@ -1755,13 +1755,17 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
     got_variable:
       e->expr_type = EXPR_VARIABLE;
       e->ts = sym->ts;
-      if (sym->as != NULL)
+      if ((sym->as != NULL && sym->ts.type != BT_CLASS)
+	  || (sym->ts.type == BT_CLASS && sym->attr.class_ok
+	      && CLASS_DATA (sym)->as))
 	{
-	  e->rank = sym->as->rank;
+	  e->rank = sym->ts.type == BT_CLASS
+		    ? CLASS_DATA (sym)->as->rank : sym->as->rank;
 	  e->ref = gfc_get_ref ();
 	  e->ref->type = REF_ARRAY;
 	  e->ref->u.ar.type = AR_FULL;
-	  e->ref->u.ar.as = sym->as;
+	  e->ref->u.ar.as = sym->ts.type == BT_CLASS
+			    ? CLASS_DATA (sym)->as : sym->as;
 	}
 
       /* Expressions are assigned a default ts.type of BT_PROCEDURE in
@@ -7945,13 +7949,8 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
       sym->attr.asynchronous = tsym->attr.asynchronous;
       sym->attr.volatile_ = tsym->attr.volatile_;
 
-      if (tsym->ts.type == BT_CLASS)
+      sym->attr.target = tsym->attr.target
-	sym->attr.target = tsym->attr.target || CLASS_DATA (tsym)->attr.pointer;
+			 || gfc_expr_attr (target).pointer;
-      else
-	sym->attr.target = tsym->attr.target || tsym->attr.pointer;
-
-      if (sym->ts.type == BT_DERIVED && tsym->ts.type == BT_CLASS)
-	target->rank = sym->as ? sym->as->rank : 0;
     }
 
   /* Get type if this was not already set.  Note that it can be
@@ -7966,10 +7965,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 			  && !gfc_has_vector_subscript (target));
 
   /* Finally resolve if this is an array or not.  */
-  if (sym->attr.dimension
+  if (sym->attr.dimension && target->rank == 0)
-	&& (target->ts.type == BT_CLASS
-	      ? !CLASS_DATA (target)->attr.dimension
-	      : target->rank == 0))
     {
       gfc_error ("Associate-name '%s' at %L is used as array",
 		 sym->name, &sym->declared_at);

gcc/fortran/trans-decl.c

@@ -3687,7 +3687,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	}
       else if ((!sym->attr.dummy || sym->ts.deferred)
 		&& (sym->ts.type == BT_CLASS
-		&& CLASS_DATA (sym)->attr.pointer))
+		&& CLASS_DATA (sym)->attr.class_pointer))
 	continue;
       else if ((!sym->attr.dummy || sym->ts.deferred)
 		&& (sym->attr.allocatable
@@ -5341,7 +5341,8 @@ gfc_generate_function_code (gfc_namespace * ns)
 							 null_pointer_node));
 	  else if (sym->ts.type == BT_CLASS
 		   && CLASS_DATA (sym)->attr.allocatable
-		   && sym->attr.dimension == 0 && sym->result == sym)
+		   && CLASS_DATA (sym)->attr.dimension == 0
+		   && sym->result == sym)
 	    {
 	      tmp = CLASS_DATA (sym)->backend_decl;
 	      tmp = fold_build3_loc (input_location, COMPONENT_REF,

gcc/fortran/trans-intrinsic.c

@@ -7237,10 +7237,11 @@ conv_intrinsic_move_alloc (gfc_code *code)
   gfc_init_se (&from_se, NULL);
   gfc_init_se (&to_se, NULL);
 
+  gcc_assert (from_expr->ts.type != BT_CLASS
+	      || to_expr->ts.type == BT_CLASS);
+
   if (from_expr->rank == 0)
     {
-      gcc_assert (from_expr->ts.type != BT_CLASS
-		  || to_expr->ts.type == BT_CLASS);
       if (from_expr->ts.type != BT_CLASS)
 	from_expr2 = from_expr;
       else

gcc/fortran/trans-stmt.c

@@ -1175,6 +1175,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
       gfc_se se;
 
       gfc_init_se (&se, NULL);
+      se.descriptor_only = 1;
       gfc_conv_expr (&se, e);
 
       gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)));

gcc/testsuite/ChangeLog

@@ -1,3 +1,9 @@
+2012-01-27  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51970
+	PR fortran/51977
+	* gfortran.dg/move_alloc_13.f90: New.
+
 2012-01-27  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/51953

gcc/testsuite/gfortran.dg/move_alloc_13.f90

@@ -0,0 +1,39 @@
+! { dg-do run}
+!
+! PR fortran/51970
+! PR fortran/51977
+!
+type t
+end type t
+type, extends(t) :: t2
+  integer :: a
+end type t2
+
+class(t), allocatable :: y(:), z(:)
+
+allocate(y(2), source=[t2(2), t2(3)])
+call func2(y,z)
+
+select type(z)
+  type is(t2)
+    if (any (z(:)%a /= [2, 3])) call abort()
+  class default
+    call abort()
+end select
+
+contains
+  function func(x)
+   class (t), allocatable :: x(:), func(:)
+   call move_alloc (x, func)
+  end function
+
+  function func1(x)
+   class (t), allocatable :: x(:), func1(:)
+   call move_alloc (func1, x)
+  end function
+
+  subroutine func2(x, y)
+   class (t), allocatable :: x(:), y(:)
+   call move_alloc (x, y)
+  end subroutine
+end