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, 30 insertions, 29 deletions

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index a490238..793ad75 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -225,7 +225,7 @@ coarray_check (gfc_expr *e, int n)
     }
 
   return SUCCESS;
-} 
+}
 
 
 /* Make sure the expression is a logical array.  */
@@ -304,7 +304,7 @@ less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2,
     {
       gfc_extract_int (expr2, &i2);
       i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false);
- 
+
       /* For ISHFT[C], check that |shift| <= bit_size(i).  */
       if (arg2 == NULL)
 	{
@@ -355,7 +355,7 @@ less_than_bitsizekind (const char *arg, gfc_expr *expr, int k)
 
   if (expr->expr_type != EXPR_CONSTANT)
     return SUCCESS;
- 
+
   i = gfc_validate_kind (BT_INTEGER, k, false);
   gfc_extract_int (expr, &val);
 
@@ -510,7 +510,7 @@ variable_check (gfc_expr *e, int n, bool allow_proc)
 		  || (ref->u.c.component->ts.type != BT_CLASS
 		      && ref->u.c.component->attr.pointer)))
 	    break;
-	} 
+	}
 
       if (!ref)
 	{
@@ -575,7 +575,7 @@ dim_corank_check (gfc_expr *dim, gfc_expr *array)
 
   if (dim->expr_type != EXPR_CONSTANT)
     return SUCCESS;
-  
+
   if (array->ts.type == BT_CLASS)
     return SUCCESS;
 
@@ -668,7 +668,7 @@ identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
 	{
 	  if (mpz_cmp (a_size, b_size) != 0)
 	    ret = 0;
-  
+
 	  mpz_clear (b_size);
 	}
       mpz_clear (a_size);
@@ -841,7 +841,7 @@ gfc_check_allocated (gfc_expr *array)
     return FAILURE;
   if (allocatable_check (array, 0) == FAILURE)
     return FAILURE;
-  
+
   return SUCCESS;
 }
 
@@ -1881,7 +1881,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
 		return SUCCESS;
 	      i = mpz_get_si (c->ts.u.cl->length->value.integer);
 	    }
-	  else 
+	  else
 	    return SUCCESS;
 	}
       else
@@ -1903,7 +1903,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
 
   if (i != 1)
     {
-      gfc_error ("Argument of %s at %L must be of length one", 
+      gfc_error ("Argument of %s at %L must be of length one",
 		 gfc_current_intrinsic, &c->where);
       return FAILURE;
     }
@@ -2037,7 +2037,7 @@ gfc_check_ishftc (gfc_expr *i, gfc_expr *shift, gfc_expr *size)
       || type_check (shift, 1, BT_INTEGER) == FAILURE)
     return FAILURE;
 
-  if (size != NULL) 
+  if (size != NULL)
     {
       int i2, i3;
 
@@ -3081,7 +3081,7 @@ gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED)
   bool is_variable = true;
 
   /* Functions returning pointers are regarded as variable, cf. F2008, R602. */
-  if (a->expr_type == EXPR_FUNCTION) 
+  if (a->expr_type == EXPR_FUNCTION)
     is_variable = a->value.function.esym
 		  ? a->value.function.esym->result->attr.pointer
 		  : a->symtree->n.sym->result->attr.pointer;
@@ -3269,7 +3269,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
 	  if (order_size != shape_size)
 	    {
 	      gfc_error ("'%s' argument of '%s' intrinsic at %L "
-			 "has wrong number of elements (%d/%d)", 
+			 "has wrong number of elements (%d/%d)",
 			 gfc_current_intrinsic_arg[3]->name,
 			 gfc_current_intrinsic, &order->where,
 			 order_size, shape_size);
@@ -3287,7 +3287,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
 	      if (dim < 1 || dim > order_size)
 		{
 		  gfc_error ("'%s' argument of '%s' intrinsic at %L "
-			     "has out-of-range dimension (%d)", 
+			     "has out-of-range dimension (%d)",
 			     gfc_current_intrinsic_arg[3]->name,
 			     gfc_current_intrinsic, &e->where, dim);
 		  return FAILURE;
@@ -3319,7 +3319,7 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
 	  gfc_constructor *c;
 	  bool test;
 
-	  
+
 	  mpz_init_set_ui (size, 1);
 	  for (c = gfc_constructor_first (shape->value.constructor);
 	       c; c = gfc_constructor_next (c))
@@ -3346,17 +3346,17 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape,
 gfc_try
 gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
 {
-
   if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS)
     {
-      gfc_error ("'%s' argument of '%s' intrinsic at %L "
-		 "must be of a derived type",
-		 gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
-		 &a->where);
-      return FAILURE;
+        gfc_error ("'%s' argument of '%s' intrinsic at %L "
+		   "cannot be of type %s",
+		   gfc_current_intrinsic_arg[0]->name,
+		   gfc_current_intrinsic,
+		   &a->where, gfc_typename (&a->ts));
+        return FAILURE;
     }
 
-  if (!gfc_type_is_extensible (a->ts.u.derived))
+  if (!(gfc_type_is_extensible (a->ts.u.derived) || UNLIMITED_POLY (a)))
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L "
 		 "must be of an extensible type",
@@ -3367,14 +3367,15 @@ gfc_check_same_type_as (gfc_expr *a, gfc_expr *b)
 
   if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS)
     {
-      gfc_error ("'%s' argument of '%s' intrinsic at %L "
-		 "must be of a derived type",
-		 gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
-		 &b->where);
+        gfc_error ("'%s' argument of '%s' intrinsic at %L "
+		   "cannot be of type %s",
+		   gfc_current_intrinsic_arg[0]->name,
+		   gfc_current_intrinsic,
+		   &b->where, gfc_typename (&b->ts));
       return FAILURE;
     }
 
-  if (!gfc_type_is_extensible (b->ts.u.derived))
+  if (!(gfc_type_is_extensible (b->ts.u.derived) || UNLIMITED_POLY (b)))
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L "
 		 "must be of an extensible type",
@@ -3688,7 +3689,7 @@ gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
     return FAILURE;
 
   /* dim_rank_check() does not apply here.  */
-  if (dim 
+  if (dim
       && dim->expr_type == EXPR_CONSTANT
       && (mpz_cmp_ui (dim->value.integer, 1) < 0
 	  || mpz_cmp_ui (dim->value.integer, source->rank + 1) > 0))
@@ -4233,7 +4234,7 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
   if (mask->rank != field->rank && field->rank != 0)
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must have "
-		 "the same rank as '%s' or be a scalar", 
+		 "the same rank as '%s' or be a scalar",
 		 gfc_current_intrinsic_arg[2]->name, gfc_current_intrinsic,
 		 &field->where, gfc_current_intrinsic_arg[1]->name);
       return FAILURE;
@@ -4246,7 +4247,7 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
 	if (! identical_dimen_shape (mask, i, field, i))
 	{
 	  gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L "
-		     "must have identical shape.", 
+		     "must have identical shape.",
 		     gfc_current_intrinsic_arg[2]->name,
 		     gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
 		     &field->where);