2011-12-05 Basile Starynkevitch <basile@starynkevitch.net>

	MELT branch merged with trunk rev 182001 using svnmerge



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@182003 138bc75d-0d04-0410-961f-82ee72b054a4

6 files changed, 119 insertions, 67 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 3fee56d891f..4b553db9011 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,29 @@
+2011-12-04  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/51383
+	* resolve.c (find_array_spec): Use ref->u.c.component
+	directly without starting from ts.u.derived.
+
+2011-12-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/48887
+	* match.c (select_type_set_tmp): Don't set allocatable/pointer
+	attribute.
+	* class.c (gfc_build_class_symbol): Handle
+	attr.select_type_temporary.
+
+2011-12-03  Tobias Burnus  <burnus@net-b.de>                                                                                                           
+
+	PR fortran/50684
+	* check.c (variable_check): Fix intent(in) check.
+
+2011-12-03  Tobias Burnus  <burnus@net-b.de>
+
+	* check.c (gfc_check_move_alloc): Allow nonpolymorphic
+	FROM with polymorphic TO.
+	* trans-intrinsic.c (conv_intrinsic_move_alloc): Handle
+	nonpolymorphic FROM with polymorphic TO.
+
 2011-12-01  Janne Blomqvist  <jb@gcc.gnu.org>
 
 	* module.c (dt_lower_string): Make static.
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 832eb6486ec..f2c4272681e 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -476,10 +476,31 @@ variable_check (gfc_expr *e, int n, bool allow_proc)
       && (gfc_current_intrinsic_arg[n]->intent == INTENT_OUT
 	  || gfc_current_intrinsic_arg[n]->intent == INTENT_INOUT))
     {
-      gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be INTENT(IN)",
-		 gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
-		 &e->where);
-      return FAILURE;
+      gfc_ref *ref;
+      bool pointer = e->symtree->n.sym->ts.type == BT_CLASS
+		     && CLASS_DATA (e->symtree->n.sym)
+		     ? CLASS_DATA (e->symtree->n.sym)->attr.class_pointer
+		     : e->symtree->n.sym->attr.pointer;
+
+      for (ref = e->ref; ref; ref = ref->next)
+	{
+	  if (pointer && ref->type == REF_COMPONENT)
+	    break;
+	  if (ref->type == REF_COMPONENT
+	      && ((ref->u.c.component->ts.type == BT_CLASS
+		   && CLASS_DATA (ref->u.c.component)->attr.class_pointer)
+		  || (ref->u.c.component->ts.type != BT_CLASS
+		      && ref->u.c.component->attr.pointer)))
+	    break;
+	} 
+
+      if (!ref)
+	{
+	  gfc_error ("'%s' argument of '%s' intrinsic at %L cannot be "
+		     "INTENT(IN)", gfc_current_intrinsic_arg[n]->name,
+		     gfc_current_intrinsic, &e->where);
+	  return FAILURE;
+	}
     }
 
   if (e->expr_type == EXPR_VARIABLE
@@ -2688,17 +2709,17 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
   if (allocatable_check (to, 1) == FAILURE)
     return FAILURE;
 
-  if (same_type_check (to, 1, from, 0) == FAILURE)
-    return FAILURE;
-
-  if (to->ts.type != from->ts.type)
+  if (from->ts.type == BT_CLASS && to->ts.type == BT_DERIVED)
     {
-      gfc_error ("The FROM and TO arguments in MOVE_ALLOC call at %L must be "
-		 "either both polymorphic or both nonpolymorphic",
+      gfc_error ("The TO arguments in MOVE_ALLOC at %L must be "
+		 "polymorphic if FROM is polymorphic",
 		 &from->where);
       return FAILURE;
     }
 
+  if (same_type_check (to, 1, from, 0) == FAILURE)
+    return FAILURE;
+
   if (to->rank != from->rank)
     {
       gfc_error ("the '%s' and '%s' arguments of '%s' intrinsic at %L must "
@@ -2718,7 +2739,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
       return FAILURE;
     }
 
-  /* CLASS arguments: Make sure the vtab is present.  */
+  /* CLASS arguments: Make sure the vtab of from is present.  */
   if (to->ts.type == BT_CLASS)
     gfc_find_derived_vtab (from->ts.u.derived);
 
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index bcb2d0b76bc..d3f7bf3ab4c 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -188,7 +188,8 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
     /* Class container has already been built.  */
     return SUCCESS;
 
-  attr->class_ok = attr->dummy || attr->pointer || attr->allocatable;
+  attr->class_ok = attr->dummy || attr->pointer || attr->allocatable
+		   || attr->select_type_temporary;
   
   if (!attr->class_ok)
     /* We can not build the class container yet.  */
@@ -239,7 +240,8 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
       c->attr.access = ACCESS_PRIVATE;
       c->ts.u.derived = ts->u.derived;
       c->attr.class_pointer = attr->pointer;
-      c->attr.pointer = attr->pointer || attr->dummy;
+      c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable)
+			|| attr->select_type_temporary;
       c->attr.allocatable = attr->allocatable;
       c->attr.dimension = attr->dimension;
       c->attr.codimension = attr->codimension;
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index fbafe82cc66..3de9c72571e 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -5152,16 +5152,11 @@ select_type_set_tmp (gfc_typespec *ts)
   gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
   gfc_add_type (tmp->n.sym, ts, NULL);
   gfc_set_sym_referenced (tmp->n.sym);
-  if (select_type_stack->selector->ts.type == BT_CLASS &&
-      CLASS_DATA (select_type_stack->selector)->attr.allocatable)
-    gfc_add_allocatable (&tmp->n.sym->attr, NULL);
-  else
-    gfc_add_pointer (&tmp->n.sym->attr, NULL);
   gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
+  tmp->n.sym->attr.select_type_temporary = 1;
   if (ts->type == BT_CLASS)
     gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
 			    &tmp->n.sym->as, false);
-  tmp->n.sym->attr.select_type_temporary = 1;
 
   /* Add an association for it, so the rest of the parser knows it is
      an associate-name.  The target will be set during resolution.  */
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 6baeff44fa7..2e50f04e5cd 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4515,14 +4515,12 @@ find_array_spec (gfc_expr *e)
 {
   gfc_array_spec *as;
   gfc_component *c;
-  gfc_symbol *derived;
   gfc_ref *ref;
 
   if (e->symtree->n.sym->ts.type == BT_CLASS)
     as = CLASS_DATA (e->symtree->n.sym)->as;
   else
     as = e->symtree->n.sym->as;
-  derived = NULL;
 
   for (ref = e->ref; ref; ref = ref->next)
     switch (ref->type)
@@ -4536,26 +4534,7 @@ find_array_spec (gfc_expr *e)
 	break;
 
       case REF_COMPONENT:
-	if (derived == NULL)
-	  derived = e->symtree->n.sym->ts.u.derived;
-
-	if (derived->attr.is_class)
-	  derived = derived->components->ts.u.derived;
-
-	c = derived->components;
-
-	for (; c; c = c->next)
-	  if (c == ref->u.c.component)
-	    {
-	      /* Track the sequence of component references.  */
-	      if (c->ts.type == BT_DERIVED)
-		derived = c->ts.u.derived;
-	      break;
-	    }
-
-	if (c == NULL)
-	  gfc_internal_error ("find_array_spec(): Component not found");
-
+	c = ref->u.c.component;
 	if (c->attr.dimension)
 	  {
 	    if (as != NULL)
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index d055275614b..855db306a7a 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -7184,7 +7184,7 @@ conv_intrinsic_move_alloc (gfc_code *code)
 {
   stmtblock_t block;
   gfc_expr *from_expr, *to_expr;
-  gfc_expr *to_expr2, *from_expr2;
+  gfc_expr *to_expr2, *from_expr2 = NULL;
   gfc_se from_se, to_se;
   gfc_ss *from_ss, *to_ss;
   tree tmp;
@@ -7199,16 +7199,21 @@ conv_intrinsic_move_alloc (gfc_code *code)
 
   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
 	{
-	  from_expr2 = to_expr;
-	  to_expr2 = to_expr;
+	  from_expr2 = gfc_copy_expr (from_expr);
+	  gfc_add_data_component (from_expr2);
 	}
+
+      if (to_expr->ts.type != BT_CLASS)
+	to_expr2 = to_expr;
       else
 	{
 	  to_expr2 = gfc_copy_expr (to_expr);
-	  from_expr2 = gfc_copy_expr (from_expr);
-	  gfc_add_data_component (from_expr2);
 	  gfc_add_data_component (to_expr2);
 	}
 
@@ -7236,48 +7241,72 @@ conv_intrinsic_move_alloc (gfc_code *code)
       gfc_add_block_to_block (&block, &to_se.post);
 
       /* Set _vptr.  */
-      if (from_expr->ts.type == BT_CLASS)
+      if (to_expr->ts.type == BT_CLASS)
 	{
-	  gfc_free_expr (from_expr2);
-          gfc_free_expr (to_expr2);
-
-	  gfc_init_se (&from_se, NULL);
+	  gfc_free_expr (to_expr2);
 	  gfc_init_se (&to_se, NULL);
-	  from_se.want_pointer = 1;
 	  to_se.want_pointer = 1;
-	  gfc_add_vptr_component (from_expr);
 	  gfc_add_vptr_component (to_expr);
-
-	  gfc_conv_expr (&from_se, from_expr);
 	  gfc_conv_expr (&to_se, to_expr);
+
+	  if (from_expr->ts.type == BT_CLASS)
+	    {
+	      gfc_free_expr (from_expr2);
+	      gfc_init_se (&from_se, NULL);
+	      from_se.want_pointer = 1;
+	      gfc_add_vptr_component (from_expr);
+	      gfc_conv_expr (&from_se, from_expr);
+	      tmp = from_se.expr;
+	    }
+	  else
+	    {
+	      gfc_symbol *vtab;
+	      vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+	      gcc_assert (vtab);
+	      tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+	    }
+
 	  gfc_add_modify_loc (input_location, &block, to_se.expr,
-			      fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
+			      fold_convert (TREE_TYPE (to_se.expr), tmp));
 	}
 
       return gfc_finish_block (&block);
     }
 
   /* Update _vptr component.  */
-  if (from_expr->ts.type == BT_CLASS)
+  if (to_expr->ts.type == BT_CLASS)
     {
-      from_se.want_pointer = 1;
       to_se.want_pointer = 1;
-
-      from_expr2 = gfc_copy_expr (from_expr);
       to_expr2 = gfc_copy_expr (to_expr);
-      gfc_add_vptr_component (from_expr2);
       gfc_add_vptr_component (to_expr2);
-
-      gfc_conv_expr (&from_se, from_expr2);
       gfc_conv_expr (&to_se, to_expr2);
 
+      if (from_expr->ts.type == BT_CLASS)
+	{
+	  from_se.want_pointer = 1;
+	  from_expr2 = gfc_copy_expr (from_expr);
+	  gfc_add_vptr_component (from_expr2);
+	  gfc_conv_expr (&from_se, from_expr2);
+	  tmp = from_se.expr;
+	}
+      else
+	{
+	  gfc_symbol *vtab;
+	  vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
+	  gcc_assert (vtab);
+	  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+	}
+
       gfc_add_modify_loc (input_location, &block, to_se.expr,
-			  fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
+			  fold_convert (TREE_TYPE (to_se.expr), tmp));
       gfc_free_expr (to_expr2);
-      gfc_free_expr (from_expr2);
-
-      gfc_init_se (&from_se, NULL);
       gfc_init_se (&to_se, NULL);
+
+      if (from_expr->ts.type == BT_CLASS)
+	{
+	  gfc_free_expr (from_expr2);
+	  gfc_init_se (&from_se, NULL);
+	}
     }
 
   /* Deallocate "to".  */