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.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@194622 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 23 insertions, 17 deletions

diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 6365213b8f0..70f06fffe99 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1,6 +1,6 @@
 /* Code translation -- generate GCC trees from gfc_code.
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2012
-   Free Software Foundation, Inc.
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
+   2012 Free Software Foundation, Inc.
    Contributed by Paul Brook
 
 This file is part of GCC.
@@ -87,7 +87,7 @@ tree
 gfc_create_var_np (tree type, const char *prefix)
 {
   tree t;
-  
+
   t = create_tmp_var_raw (type, prefix);
 
   /* No warnings for anonymous variables.  */
@@ -139,7 +139,7 @@ gfc_evaluate_now (tree expr, stmtblock_t * pblock)
 }
 
 
-/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.  
+/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK.
    A MODIFY_EXPR is an assignment:
    LHS <- RHS.  */
 
@@ -428,7 +428,7 @@ trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
   arg = gfc_build_addr_expr (pchar_type_node,
 			     gfc_build_localized_cstring_const (message));
   free (message);
-  
+
   asprintf (&message, "%s", _(msgid));
   arg2 = gfc_build_addr_expr (pchar_type_node,
 			      gfc_build_localized_cstring_const (message));
@@ -440,7 +440,7 @@ trans_runtime_error_vararg (bool error, locus* where, const char* msgid,
   argarray[1] = arg2;
   for (i = 0; i < nargs; i++)
     argarray[2 + i] = va_arg (ap, tree);
-  
+
   /* Build the function call to runtime_(warning,error)_at; because of the
      variable number of arguments, we can't use build_call_expr_loc dinput_location,
      irectly.  */
@@ -591,14 +591,14 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size)
 
 
 /* Allocate memory, using an optional status argument.
- 
+
    This function follows the following pseudo-code:
 
     void *
     allocate (size_t size, integer_type stat)
     {
       void *newmem;
-    
+
       if (stat requested)
 	stat = 0;
 
@@ -661,7 +661,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
 
 
 /* Allocate memory, using an optional status argument.
- 
+
    This function follows the following pseudo-code:
 
     void *
@@ -717,9 +717,9 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
 /* Generate code for an ALLOCATE statement when the argument is an
    allocatable variable.  If the variable is currently allocated, it is an
    error to allocate it again.
- 
+
    This function follows the following pseudo-code:
-  
+
     void *
     allocate_allocatable (void *mem, size_t size, integer_type stat)
     {
@@ -733,7 +733,7 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
 	  runtime_error ("Attempting to allocate already allocated variable");
       }
     }
-    
+
     expr must be set to the original expression being allocated for its locus
     and variable name in case a runtime error has to be printed.  */
 void
@@ -866,7 +866,7 @@ gfc_call_free (tree var)
    even when no status variable is passed to us (this is used for
    unconditional deallocation generated by the front-end at end of
    each procedure).
-   
+
    If a runtime-message is possible, `expr' must point to the original
    expression being deallocated for its locus and variable name.
 
@@ -1075,7 +1075,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
 
   /* When POINTER is not NULL, we free it.  */
   gfc_start_block (&non_null);
-  
+
   /* Free allocatable components.  */
   if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp)
     {
@@ -1091,7 +1091,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail,
 				       tmp, 0);
       gfc_add_expr_to_block (&non_null, tmp);
     }
-  
+
   tmp = build_call_expr_loc (input_location,
 			     builtin_decl_explicit (BUILT_IN_FREE), 1,
 			     fold_convert (pvoid_type_node, pointer));
@@ -1320,6 +1320,12 @@ trans_code (gfc_code * code, tree cond)
 	case EXEC_POINTER_ASSIGN:
 	  if (code->expr1->ts.type == BT_CLASS)
 	    res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
+	  else if (UNLIMITED_POLY (code->expr2)
+		   && code->expr1->ts.type == BT_DERIVED
+		   && (code->expr1->ts.u.derived->attr.sequence
+		       || code->expr1->ts.u.derived->attr.is_bind_c))
+	    /* F2003: C717  */
+	    res = gfc_trans_class_assign (code->expr1, code->expr2, code->op);
 	  else
 	    res = gfc_trans_pointer_assign (code);
 	  break;
@@ -1544,7 +1550,7 @@ trans_code (gfc_code * code, tree cond)
 	{
 	  if (TREE_CODE (res) != STATEMENT_LIST)
 	    SET_EXPR_LOCATION (res, input_location);
-	    
+
 	  /* Add the new statement to the block.  */
 	  gfc_add_expr_to_block (&block, res);
 	}
@@ -1686,7 +1692,7 @@ gfc_finish_wrapped_block (gfc_wrapped_block* block)
   if (block->cleanup)
     result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node,
 			 result, block->cleanup);
-  
+
   /* Clear the block.  */
   block->init = NULL_TREE;
   block->code = NULL_TREE;