array.c (resolve_array_list): Apply C4106.

2012-12-19  Paul Thomas  <pault@gcc.gnu.org>

	* array.c (resolve_array_list): Apply C4106.
	* check.c (gfc_check_same_type_as): Exclude polymorphic
	entities from check for extensible types. Improved error
	for disallowed argument types to name the offending type.
	* class.c : Update copyright date.
	(gfc_class_null_initializer): Add argument for initialization
	expression and deal with unlimited polymorphic typespecs.
	(get_unique_type_string): Give unlimited polymorphic
	entities a type string.
	(gfc_intrinsic_hash_value): New function.
	(gfc_build_class_symbol): Incorporate unlimited polymorphic
	entities.
	(gfc_find_derived_vtab): Deal with unlimited polymorphic
	entities.
	(gfc_find_intrinsic_vtab): New function.
	* decl.c (gfc_match_decl_type_spec): Match typespec for
	unlimited polymorphic type.
	(gfc_match_data_decl): Skip to 'ok' if unlimited polymorphic.
	expr.c (gfc_check_pointer_assign): Apply C717.  If unlimited
	polymorphic lvalue, find rvalue vtable for all typespecs,
	except unlimited polymorphic expressions.
	(gfc_check_vardef_context): Handle unlimited polymorphic
	entities.
	* gfortran.h : Add unlimited polymorphic attribute. Add
	second arg to gfc_class_null_initializer primitive and
	primitive for gfc_find_intrinsic_vtab.  Add UNLIMITED_POLY
	to detect unlimited polymorphic expressions.
	* interface.c (gfc_compare_types): If expr1 is unlimited
	polymorphic, always return 1. If expr2 is unlimited polymorphic
	enforce C717.
	(gfc_compare_interfaces): Skip past conditions that do not
	apply for unlimited polymorphic entities.
	(compare_parameter): Make sure that an unlimited polymorphic,
	allocatable or pointer, formal argument is matched by an
	unlimited polymorphic actual argument.
	(compare_actual_formal): Ensure that an intrinsic vtable exists
	to match an unlimited polymorphic formal argument.
	* match.c (gfc_match_allocate): Type kind parameter does not
	need to match an unlimited polymorphic allocate-object.
	(alloc_opt_list): An unlimited polymorphic allocate-object
	requires a typespec or a SOURCE tag.
	(select_intrinsic_set_tmp): New function.
	(select_type_set_tmp): Call new function.  If it returns NULL,
	build a derived type or class temporary instead.
	(gfc_match_type_is): Remove restriction to derived types only.
	Bind(C) or sequence derived types not permitted.
	* misc (gfc_typename):  Printed CLASS(*) for unlimited
	polymorphism.
	* module.c : Add AB_UNLIMITED_POLY to pass unlimited
	polymorphic attribute to and from modules.
	* resolve.c (resolve_common_vars): Unlimited polymorphic
	entities cannot appear in common blocks.
	(resolve_deallocate_expr): Deallocate unlimited polymorphic
	enities.
	(resolve_allocate_expr): Likewise for allocation.  Make sure
	vtable exists.
	(gfc_type_is_extensible): Unlimited polymorphic entities are
	not extensible.
	(resolve_select_type): Handle unlimited polymorphic selectors.
	Ensure that length type parameters are assumed and that names
	for intrinsic types are generated.
	(resolve_fl_var_and_proc): Exclude select type temporaries
	from test of extensibility of type.
	(resolve_fl_variable): Likewise for test that assumed character
	length must be a dummy or a parameter.
	(resolve_fl_derived0): Return SUCCESS unconditionally for
	unlimited polymorphic entities. Also, allow unlimited
	polymorphic components.
	(resolve_fl_derived): Return SUCCESS unconditionally for
	unlimited polymorphic entities.
	(resolve_symbol): Return early with unlimited polymorphic
	entities.
	* simplifiy.c : Update copyright year.
	(gfc_simplify_extends_type_of): No simplification possible
	for unlimited polymorphic arguments.
	* symbol.c (gfc_use_derived): Nothing to do for unlimited
	polymorphic "derived type".
	(gfc_type_compatible): Return unity if ts1 is unlimited
	polymorphic.
	* trans-decl.c (create_function_arglist) Formal arguments
	without a character length should be treated in the same way
	as passed lengths.
	(gfc_trans_deferred_vars): Nullify the vptr of unlimited
	polymorphic pointers. Avoid unlimited polymorphic entities
	triggering gcc_unreachable.
	* trans-expr.c (gfc_conv_intrinsic_to_class): New function.
	(gfc_trans_class_init_assign): Make indirect reference of
	src.expr.
	(gfc_trans_class_assign): Expression NULL of unknown type
	should set NULL vptr on lhs. Treat C717 cases where lhs is
	a derived type and the rhs is unlimited polymorphic.
	(gfc_conv_procedure_call): Handle the conversion of a non-class
	actual argument to match an unlimited polymorphic formal
	argument.  Suppress the passing of a character string length
	in this case.  Make sure that calls to the character __copy
	function have two character string length arguments.
	(gfc_conv_initializer): Pass the initialization expression to
	gfc_class_null_initializer.
	(gfc_trans_subcomponent_assign): Ditto.
	(gfc_conv_structure): Move handling of _size component.
	trans-intrinsic.c: (gfc_conv_same_type_as): Handle conditions
	where unlimited polymorphic arguments have null vptr.
	* trans-stmt.c (trans_associate_var): Correctly treat array
	temporaries associated with unlimited polymorphic selectors.
	Recover the overwritten dtype for the descriptor. Use the _size
	field of the vptr for character string lengths.
	(gfc_trans_allocate): Cope with unlimited polymorphic allocate
	objects; especially with character source tags.
	(reset_vptr): New function.
	(gfc_trans_deallocate): Call it.
	* trans-types.c (gfc_get_derived_type): Detect unlimited
	polymorphic types and deal with cases where the derived type of
	components is null.
	* trans.c : Update copyright year.
	(trans_code): Call gfc_trans_class_assign for C717 cases where
	the lhs is not unlimited polymorphic.

2012-12-19  Paul Thomas  <pault@gcc.gnu.org>

	* intrinsics/extends_type_of.c : Return correct results for
	null vptrs.

2012-12-19  Paul Thomas  <pault@gcc.gnu.org>

	* gfortran.dg/unlimited_polymorphic_1.f03: New test.
	* gfortran.dg/unlimited_polymorphic_2.f03: New test.
	* gfortran.dg/unlimited_polymorphic_3.f03: New test.
	* gfortran.dg/same_type_as.f03: Correct for improved message.

From-SVN: r194622

1 files changed, 47 insertions, 29 deletions

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index b535e8a..5c9ce11 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -729,10 +729,10 @@ gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
   mpz_t *new_shape, *s;
   int i, n;
 
-  if (shape == NULL 
+  if (shape == NULL
       || rank <= 1
       || dim == NULL
-      || dim->expr_type != EXPR_CONSTANT 
+      || dim->expr_type != EXPR_CONSTANT
       || dim->ts.type != BT_INTEGER)
     return NULL;
 
@@ -1389,7 +1389,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
 
 	  gcc_assert (begin->rank == 1);
 	  /* Zero-sized arrays have no shape and no elements, stop early.  */
-	  if (!begin->shape) 
+	  if (!begin->shape)
 	    {
 	      mpz_init_set_ui (nelts, 0);
 	      break;
@@ -1473,7 +1473,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
 
 	  /* An element reference reduces the rank of the expression; don't
 	     add anything to the shape array.  */
-	  if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT) 
+	  if (ref->u.ar.dimen_type[d] != DIMEN_ELEMENT)
 	    mpz_set (expr->shape[shape_i++], tmp_mpz);
 	}
 
@@ -1520,7 +1520,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
 	    }
 	  else
 	    {
-	      mpz_add (ctr[d], ctr[d], stride[d]); 
+	      mpz_add (ctr[d], ctr[d], stride[d]);
 
 	      if (mpz_cmp_ui (stride[d], 0) > 0
 		  ? mpz_cmp (ctr[d], end[d]) > 0
@@ -1952,7 +1952,7 @@ scalarize_intrinsic_call (gfc_expr *e)
   gfc_constructor *ci, *new_ctor;
   gfc_expr *expr, *old;
   int n, i, rank[5], array_arg;
-  
+
   /* Find which, if any, arguments are arrays.  Assume that the old
      expression carries the type information and that the first arg
      that is an array expression carries all the shape information.*/
@@ -2105,7 +2105,7 @@ check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
     case INTRINSIC_LE_OS:
       if ((*check_function) (op2) == FAILURE)
 	return FAILURE;
-      
+
       if (!(et0 (op1) == BT_CHARACTER && et0 (op2) == BT_CHARACTER)
 	  && !(numeric_type (et0 (op1)) && numeric_type (et0 (op2))))
 	{
@@ -2271,7 +2271,7 @@ check_inquiry (gfc_expr *e, int not_restricted)
 
   name = e->symtree->n.sym->name;
 
-  functions = (gfc_option.warn_std & GFC_STD_F2003) 
+  functions = (gfc_option.warn_std & GFC_STD_F2003)
 		? inquiry_func_f2003 : inquiry_func_f95;
 
   for (i = 0; functions[i]; i++)
@@ -2360,7 +2360,7 @@ check_transformational (gfc_expr *e)
 
   name = e->symtree->n.sym->name;
 
-  functions = (gfc_option.allow_std & GFC_STD_F2003) 
+  functions = (gfc_option.allow_std & GFC_STD_F2003)
 		? trans_func_f2003 : trans_func_f95;
 
   /* NULL() is dealt with below.  */
@@ -3097,7 +3097,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
 		|| gfc_current_ns->parent->proc_name->attr.subroutine)
 	      || gfc_current_ns->parent->proc_name->attr.is_main_program))
 	{
-	  /* ... that is not a function...  */ 
+	  /* ... that is not a function...  */
 	  if (!gfc_current_ns->proc_name->attr.function)
 	    bad_proc = true;
 
@@ -3137,7 +3137,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
     }
 
   if (rvalue->expr_type == EXPR_NULL)
-    {  
+    {
       if (has_pointer && (ref == NULL || ref->next == NULL)
 	  && lvalue->symtree->n.sym->attr.data)
         return SUCCESS;
@@ -3150,7 +3150,7 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
     }
 
   /* This is possibly a typo: x = f() instead of x => f().  */
-  if (gfc_option.warn_surprising 
+  if (gfc_option.warn_surprising
       && rvalue->expr_type == EXPR_FUNCTION
       && rvalue->symtree->n.sym->attr.pointer)
     gfc_warning ("POINTER valued function appears on right-hand side of "
@@ -3222,15 +3222,15 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
 	      mpfr_init (rv);
 	      gfc_set_model_kind (rvalue->ts.kind);
 	      mpfr_init (diff);
-	      
+
 	      mpfr_set (rv, rvalue->value.real, GFC_RND_MODE);
 	      mpfr_sub (diff, rv, rvalue->value.real, GFC_RND_MODE);
-	  
+
 	      if (!mpfr_zero_p (diff))
 		gfc_warning ("Change of value in conversion from "
 			     " %s to %s at %L", gfc_typename (&rvalue->ts),
 			     gfc_typename (&lvalue->ts), &rvalue->where);
-	      
+
 	      mpfr_clear (rv);
 	      mpfr_clear (diff);
 	    }
@@ -3550,9 +3550,22 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 
   if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
     {
-      gfc_error ("Different types in pointer assignment at %L; attempted "
-		 "assignment of %s to %s", &lvalue->where, 
-		 gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
+      /* Check for F03:C717.  */
+      if (UNLIMITED_POLY (rvalue)
+	  && !(UNLIMITED_POLY (lvalue)
+	       || (lvalue->ts.type == BT_DERIVED
+		   && (lvalue->ts.u.derived->attr.is_bind_c
+		       || lvalue->ts.u.derived->attr.sequence))))
+	gfc_error ("Data-pointer-object &L must be unlimited "
+		   "polymorphic, a sequence derived type or of a "
+		   "type with the BIND attribute assignment at %L "
+		   "to be compatible with an unlimited polymorphic "
+		   "target", &lvalue->where);
+      else
+	gfc_error ("Different types in pointer assignment at %L; "
+		   "attempted assignment of %s to %s", &lvalue->where,
+		   gfc_typename (&rvalue->ts),
+		   gfc_typename (&lvalue->ts));
       return FAILURE;
     }
 
@@ -3569,9 +3582,11 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
       return FAILURE;
     }
 
-  if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
     /* Make sure the vtab is present.  */
+  if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
     gfc_find_derived_vtab (rvalue->ts.u.derived);
+  else if (UNLIMITED_POLY (lvalue) && !UNLIMITED_POLY (rvalue))
+    gfc_find_intrinsic_vtab (&rvalue->ts);
 
   /* Check rank remapping.  */
   if (rank_remap)
@@ -3647,7 +3662,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
 
   if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym))
     gfc_current_ns->proc_name->attr.implicit_pure = 0;
-    
+
 
   if (gfc_has_vector_index (rvalue))
     {
@@ -3747,7 +3762,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
 
   if (r == FAILURE)
     return r;
-  
+
   if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL)
     {
       /* F08:C461. Additional checks for pointer initialization.  */
@@ -3772,7 +3787,7 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
 	  return FAILURE;
 	}
     }
-    
+
   if (sym->attr.proc_pointer && rvalue->expr_type != EXPR_NULL)
     {
       /* F08:C1220. Additional checks for procedure pointer initialization.  */
@@ -4251,7 +4266,7 @@ gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
 static bool
 replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
 {
-  if ((expr->expr_type == EXPR_VARIABLE 
+  if ((expr->expr_type == EXPR_VARIABLE
        || (expr->expr_type == EXPR_FUNCTION
 	   && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
       && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns
@@ -4285,7 +4300,7 @@ replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
 {
   gfc_component *comp;
   comp = (gfc_component *)sym;
-  if ((expr->expr_type == EXPR_VARIABLE 
+  if ((expr->expr_type == EXPR_VARIABLE
        || (expr->expr_type == EXPR_FUNCTION
 	   && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
       && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
@@ -4421,7 +4436,7 @@ gfc_get_corank (gfc_expr *e)
   if (e->ts.type == BT_CLASS && e->ts.u.derived->components)
     corank = e->ts.u.derived->components->as
 	     ? e->ts.u.derived->components->as->corank : 0;
-  else 
+  else
     corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
 
   for (ref = e->ref; ref; ref = ref->next)
@@ -4478,7 +4493,7 @@ gfc_has_ultimate_pointer (gfc_expr *e)
   for (ref = e->ref; ref; ref = ref->next)
     if (ref->type == REF_COMPONENT)
       last = ref;
- 
+
   if (last && last->u.c.component->ts.type == BT_CLASS)
     return CLASS_DATA (last->u.c.component)->attr.pointer_comp;
   else if (last && last->u.c.component->ts.type == BT_DERIVED)
@@ -4598,7 +4613,7 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
 			  ar->as->upper[i]->value.integer) != 0))
 	colon = false;
     }
-  
+
   return true;
 }
 
@@ -4618,7 +4633,7 @@ gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
 
   isym = gfc_find_function (name);
   gcc_assert (isym);
-  
+
   result = gfc_get_expr ();
   result->expr_type = EXPR_FUNCTION;
   result->ts = isym->ts;
@@ -4669,6 +4684,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
   bool is_pointer;
   bool check_intentin;
   bool ptr_component;
+  bool unlimited;
   symbol_attribute attr;
   gfc_ref* ref;
 
@@ -4683,6 +4699,8 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
       sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym;
     }
 
+  unlimited = e->ts.type == BT_CLASS && UNLIMITED_POLY (sym);
+
   attr = gfc_expr_attr (e);
   if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer)
     {
@@ -4722,7 +4740,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
   /* Find out whether the expr is a pointer; this also means following
      component references to the last one.  */
   is_pointer = (attr.pointer || attr.proc_pointer);
-  if (pointer && !is_pointer)
+  if (pointer && !is_pointer && !unlimited)
     {
       if (context)
 	gfc_error ("Non-POINTER in pointer association context (%s)"