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, 32 insertions, 26 deletions

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 588f55a..88f9c56 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -327,7 +327,7 @@ gfc_sym_mangled_identifier (gfc_symbol * sym)
      binding label (mainly those that are bind(c)).  */
   if (sym->attr.is_bind_c == 1 && sym->binding_label)
     return get_identifier (sym->binding_label);
-  
+
   if (sym->module == NULL)
     return gfc_sym_identifier (sym);
   else
@@ -433,14 +433,14 @@ gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
   tree value;
 
   /* Parameters need to be dereferenced.  */
-  if (sym->cp_pointer->attr.dummy) 
+  if (sym->cp_pointer->attr.dummy)
     ptr_decl = build_fold_indirect_ref_loc (input_location,
 					ptr_decl);
 
   /* Check to see if we're dealing with a variable-sized array.  */
   if (sym->attr.dimension
-      && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE) 
-    {  
+      && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
+    {
       /* These decls will be dereferenced later, so we don't dereference
 	 them here.  */
       value = convert (TREE_TYPE (decl), ptr_decl);
@@ -483,7 +483,7 @@ gfc_finish_decl (tree decl)
 
   /* We should know the storage size.  */
   gcc_assert (DECL_SIZE (decl) != NULL_TREE
-	      || (TREE_STATIC (decl) 
+	      || (TREE_STATIC (decl)
 		  ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
 		  : DECL_EXTERNAL (decl)));
 
@@ -550,7 +550,7 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
       TREE_PUBLIC(decl) = 1;
       DECL_COMMON(decl) = 1;
     }
-  
+
   /* If a variable is USE associated, it's always external.  */
   if (sym->attr.use_assoc)
     {
@@ -592,7 +592,7 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
       TREE_SIDE_EFFECTS (decl) = 1;
       new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
       TREE_TYPE (decl) = new_type;
-    } 
+    }
 
   /* Keep variables larger than max-stack-var-size off stack.  */
   if (!sym->ns->proc_name->attr.recursive
@@ -948,7 +948,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
   /* Do we know the element size?  */
   known_size = sym->ts.type != BT_CHARACTER
 	  || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
-  
+
   if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
     {
       /* For descriptorless arrays with known element size the actual
@@ -1558,7 +1558,7 @@ get_proc_pointer_decl (gfc_symbol *sym)
       if (sym->attr.use_assoc)
 	DECL_IGNORED_P (decl) = 1;
     }
-  
+
   if ((sym->ns->proc_name
       && sym->ns->proc_name->backend_decl == current_function_decl)
       || sym->attr.contained)
@@ -1984,7 +1984,7 @@ create_function_arglist (gfc_symbol * sym)
       type = TREE_VALUE (typelist);
       parm = build_decl (input_location,
 			 PARM_DECL, get_identifier ("__entry"), type);
-      
+
       DECL_CONTEXT (parm) = fndecl;
       DECL_ARG_TYPE (parm) = type;
       TREE_READONLY (parm) = 1;
@@ -2106,7 +2106,7 @@ create_function_arglist (gfc_symbol * sym)
 	  gfc_finish_decl (length);
 
 	  /* Remember the passed value.  */
-          if (f->sym->ts.u.cl->passed_length != NULL)
+          if (!f->sym->ts.u.cl ||  f->sym->ts.u.cl->passed_length)
             {
 	      /* This can happen if the same type is used for multiple
 		 arguments. We need to copy cl as otherwise
@@ -2215,7 +2215,7 @@ create_function_arglist (gfc_symbol * sym)
 	      gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
 	      GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
 	    }
-	    
+
 	  DECL_CONTEXT (token) = fndecl;
 	  DECL_ARTIFICIAL (token) = 1;
 	  DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
@@ -2314,7 +2314,7 @@ build_entry_thunks (gfc_namespace * ns, bool global)
       vec<tree, va_gc> *string_args = NULL;
 
       thunk_sym = el->sym;
-      
+
       build_function_decl (thunk_sym, global);
       create_function_arglist (thunk_sym);
 
@@ -2411,7 +2411,7 @@ build_entry_thunks (gfc_namespace * ns, bool global)
 	  tmp = fold_build3_loc (input_location, COMPONENT_REF,
 				 TREE_TYPE (field), union_decl, field,
 				 NULL_TREE);
-	  tmp = fold_build2_loc (input_location, MODIFY_EXPR, 
+	  tmp = fold_build2_loc (input_location, MODIFY_EXPR,
 			     TREE_TYPE (DECL_RESULT (current_function_decl)),
 			     DECL_RESULT (current_function_decl), tmp);
 	  tmp = build1_v (RETURN_EXPR, tmp);
@@ -2985,7 +2985,7 @@ gfc_build_intrinsic_function_decls (void)
 	gfc_int4_type_node);
   TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
   TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
-	
+
   gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl (
 	get_identifier (PREFIX("ishftc8")),
 	gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node,
@@ -3121,7 +3121,7 @@ gfc_build_builtin_function_decls (void)
 	void_type_node, -2, pchar_type_node, pchar_type_node);
   /* The runtime_error_at function does not return.  */
   TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
-  
+
   gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec (
 	get_identifier (PREFIX("runtime_warning_at")), ".RR",
 	void_type_node, -2, pchar_type_node, pchar_type_node);
@@ -3816,7 +3816,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	      if (sym->ts.type == BT_CLASS)
 		{
 		  /* Initialize _vptr to declared type.  */
-		  gfc_symbol *vtab = gfc_find_derived_vtab (sym->ts.u.derived);
+		  gfc_symbol *vtab;
 		  tree rhs;
 
 		  gfc_save_backend_locus (&loc);
@@ -3827,8 +3827,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 		  se.want_pointer = 1;
 		  gfc_conv_expr (&se, e);
 		  gfc_free_expr (e);
-		  rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
-					     gfc_get_symbol_decl (vtab));
+		  if (UNLIMITED_POLY (sym))
+		    rhs = build_int_cst (TREE_TYPE (se.expr), 0);
+		  else
+		    {
+		      vtab = gfc_find_derived_vtab (sym->ts.u.derived);
+		      rhs = gfc_build_addr_expr (TREE_TYPE (se.expr),
+						gfc_get_symbol_decl (vtab));
+		    }
 		  gfc_add_modify (&init, se.expr, rhs);
 		  gfc_restore_backend_locus (&loc);
 		}
@@ -3894,7 +3900,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	  gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
 				NULL_TREE);
 	}
-      else
+      else if (!(UNLIMITED_POLY(sym)))
 	gcc_unreachable ();
     }
 
@@ -4347,7 +4353,7 @@ generate_coarray_sym_init (gfc_symbol *sym)
   tree tmp, size, decl, token;
 
   if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
-      || sym->attr.use_assoc || !sym->attr.referenced) 
+      || sym->attr.use_assoc || !sym->attr.referenced)
     return;
 
   decl = sym->backend_decl;
@@ -4360,7 +4366,7 @@ generate_coarray_sym_init (gfc_symbol *sym)
 
   size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
 
-  /* Ensure that we do not have size=0 for zero-sized arrays.  */ 
+  /* Ensure that we do not have size=0 for zero-sized arrays.  */
   size = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
 			  fold_convert (size_type_node, size),
 			  build_int_cst (size_type_node, 1));
@@ -4382,7 +4388,7 @@ generate_coarray_sym_init (gfc_symbol *sym)
 			     token, null_pointer_node, /* token, stat.  */
 			     null_pointer_node, /* errgmsg, errmsg_len.  */
 			     build_int_cst (integer_type_node, 0));
-  
+
   gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), tmp));
 
 
@@ -4724,7 +4730,7 @@ generate_local_decl (gfc_symbol * sym)
 	    {
 	      if (gfc_option.warn_unused_dummy_argument)
 		gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
-			     &sym->declared_at);	     
+			     &sym->declared_at);
 	    }
 
 	  /* Silence bogus "unused parameter" warnings from the
@@ -5151,9 +5157,9 @@ create_main_function (tree fndecl)
 
   /* Coarray: Call _gfortran_caf_finalize(void).  */
   if (gfc_option.coarray == GFC_FCOARRAY_LIB)
-    { 
+    {
       /* Per F2008, 8.5.1 END of the main program implies a
-	 SYNC MEMORY.  */ 
+	 SYNC MEMORY.  */
       tmp = builtin_decl_explicit (BUILT_IN_SYNC_SYNCHRONIZE);
       tmp = build_call_expr_loc (input_location, tmp, 0);
       gfc_add_expr_to_block (&body, tmp);