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, 57 insertions, 20 deletions

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index d90fc73..908db74 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -214,7 +214,7 @@ gfc_match_interface (void)
       if (gfc_get_symbol (name, NULL, &sym))
 	return MATCH_ERROR;
 
-      if (!sym->attr.generic 
+      if (!sym->attr.generic
 	  && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
 	return MATCH_ERROR;
 
@@ -351,7 +351,7 @@ gfc_match_end_interface (void)
 	      gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C, "
 			 "but got %s", s1, s2);
 	    }
-		
+
 	}
 
       break;
@@ -446,7 +446,7 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
       if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
 	return 0;
 
-      /* Make sure that link lists do not put this function into an 
+      /* Make sure that link lists do not put this function into an
 	 endless recursive loop!  */
       if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
 	    && !(dt2->ts.type == BT_DERIVED && derived2 == dt2->ts.u.derived)
@@ -485,7 +485,17 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
      that is for the formal arg, but oh well.  */
   if (ts1->type == BT_VOID || ts2->type == BT_VOID)
     return 1;
-   
+
+  if (ts1->type == BT_CLASS
+      && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
+    return 1;
+
+  /* F2003: C717  */
+  if (ts2->type == BT_CLASS && ts1->type == BT_DERIVED
+      && ts2->u.derived->components->ts.u.derived->attr.unlimited_polymorphic
+      && (ts1->u.derived->attr.sequence || ts1->u.derived->attr.is_bind_c))
+    return 1;
+
   if (ts1->type != ts2->type
       && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
 	  || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
@@ -523,7 +533,7 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
     return 0;			/* Ranks differ.  */
 
   return gfc_compare_types (&s1->ts, &s2->ts)
-	 || s1->ts.type == BT_ASSUMED || s2->ts.type == BT_ASSUMED; 
+	 || s1->ts.type == BT_ASSUMED || s2->ts.type == BT_ASSUMED;
 }
 
 
@@ -1157,7 +1167,7 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
 	    }
 	  }
     }
-    
+
   return SUCCESS;
 }
 
@@ -1403,6 +1413,9 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
 	    return 0;
 	  }
 
+	if (UNLIMITED_POLY (f1->sym))
+	  goto next;
+
 	if (strict_flag)
 	  {
 	    /* Check all characteristics.  */
@@ -1418,7 +1431,7 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
 			f1->sym->name);
 	    return 0;
 	  }
-
+next:
 	f1 = f1->next;
 	f2 = f2->next;
       }
@@ -1712,7 +1725,7 @@ gfc_check_interfaces (gfc_namespace *ns)
       for (ns2 = ns; ns2; ns2 = ns2->parent)
 	{
 	  gfc_intrinsic_op other_op;
-	  
+
 	  if (check_interface1 (ns->op[i], ns2->op[i], 0,
 				interface_name, true))
 	    goto done;
@@ -1814,7 +1827,7 @@ argument_rank_mismatch (const char *name, locus *where,
 		 "(rank-%d and scalar)", name, where, rank1);
     }
   else
-    {    
+    {
       gfc_error ("Rank mismatch in argument '%s' at %L "
 		 "(rank-%d and rank-%d)", name, where, rank1, rank2);
     }
@@ -1900,7 +1913,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
       && formal->ts.type != BT_ASSUMED
       && !gfc_compare_types (&formal->ts, &actual->ts)
       && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS
-	   && gfc_compare_derived_types (formal->ts.u.derived, 
+	   && gfc_compare_derived_types (formal->ts.u.derived,
 					 CLASS_DATA (actual)->ts.u.derived)))
     {
       if (where)
@@ -1933,6 +1946,23 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 	}
     }
 
+  /* F08: 12.5.2.5 Allocatable and pointer dummy variables.  However, this
+     is necessary also for F03, so retain error for both.
+     NOTE: Other type/kind errors pre-empt this error.  Since they are F03
+     compatible, no attempt has been made to channel to this one.  */
+  if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual)
+      && (CLASS_DATA (formal)->attr.allocatable
+	  ||CLASS_DATA (formal)->attr.class_pointer))
+    {
+      if (where)
+	gfc_error ("Actual argument to '%s' at %L must be unlimited "
+		   "polymorphic since the formal argument is a "
+		   "pointer or allocatable unlimited polymorphic "
+		   "entity [F2008: 12.5.2.5]", formal->name,
+		   &actual->where);
+      return 0;
+    }
+
   if (formal->attr.codimension && !gfc_is_coarray (actual))
     {
       if (where)
@@ -2078,7 +2108,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
 	is_pointer = ref->u.c.component->attr.pointer;
       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
 	       && ref->u.ar.dimen > 0
-	       && (!ref->next 
+	       && (!ref->next
 		   || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
         break;
     }
@@ -2156,7 +2186,7 @@ get_sym_storage_size (gfc_symbol *sym)
 	return 0;
     }
   else
-    strlen = 1; 
+    strlen = 1;
 
   if (symbol_rank (sym) == 0)
     return strlen;
@@ -2194,7 +2224,7 @@ get_expr_storage_size (gfc_expr *e)
 
   if (e == NULL)
     return 0;
-  
+
   if (e->ts.type == BT_CHARACTER)
     {
       if (e->ts.u.cl && e->ts.u.cl->length
@@ -2455,6 +2485,13 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 	  return 0;
 	}
 
+      /* Make sure that intrinsic vtables exist for calls to unlimited
+	 polymorphic formal arguments.  */
+      if (UNLIMITED_POLY(f->sym)
+	  && a->expr->ts.type != BT_DERIVED
+	  && a->expr->ts.type != BT_CLASS)
+	gfc_find_intrinsic_vtab (&a->expr->ts);
+
       if (a->expr->expr_type == EXPR_NULL
 	  && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
 	       && (f->sym->attr.allocatable || !f->sym->attr.optional
@@ -2478,7 +2515,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 
 	  return 0;
 	}
-      
+
       if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
 			      is_elemental, where))
 	return 0;
@@ -2628,7 +2665,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
 		       "pointer dummy '%s'", &a->expr->where,f->sym->name);
 	  return 0;
 	}
-	
+
 
       /* Fortran 2008, C1242.  */
       if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
@@ -3283,7 +3320,7 @@ gfc_search_interface (gfc_interface *intr, int sub_flag,
 	has_null_arg = true;
 	null_expr_loc = a->expr->where;
 	break;
-      } 
+      }
 
   for (; intr; intr = intr->next)
     {
@@ -3310,7 +3347,7 @@ gfc_search_interface (gfc_interface *intr, int sub_flag,
 	    }
 
 	  /* Satisfy 12.4.4.1 such that an elemental match has lower
-	     weight than a non-elemental match.  */ 
+	     weight than a non-elemental match.  */
 	  if (intr->sym->attr.elemental)
 	    {
 	      elem_sym = intr->sym;
@@ -3613,7 +3650,7 @@ gfc_extend_expr (gfc_expr *e)
 	      tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
 	      break;
 	  }
-	      
+
       /* If there is a matching typebound-operator, replace the expression with
 	 a call to it and succeed.  */
       if (tbo)
@@ -3703,7 +3740,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
       /* See if we find a matching type-bound assignment.  */
       tbo = matching_typebound_op (&tb_base, actual,
 				   INTRINSIC_ASSIGN, NULL, &gname);
-	      
+
       /* If there is one, replace the expression with a call to it and
 	 succeed.  */
       if (tbo)
@@ -4028,7 +4065,7 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
 		     " FUNCTION", proc->name, &where);
 	  return FAILURE;
 	}
-	
+
       if (check_result_characteristics (proc_target, old_target,
 					err, sizeof(err)) == FAILURE)
 	{