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, 165 insertions, 66 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 42f6e0c..ad26684 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -64,7 +64,7 @@ get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
 static tree
 conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
 {
-  tree desc, type;  
+  tree desc, type;
 
   type = get_scalar_to_descriptor_type (scalar, attr);
   desc = gfc_create_var (type, "desc");
@@ -456,9 +456,68 @@ class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
 }
 
 
+/* Takes an intrinsic type expression and returns the address of a temporary
+   class object of the 'declared' type.  */
+void
+gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
+			     gfc_typespec class_ts)
+{
+  gfc_symbol *vtab;
+  gfc_ss *ss;
+  tree ctree;
+  tree var;
+  tree tmp;
+
+  /* The intrinsic type needs to be converted to a temporary
+     CLASS object.  */
+  tmp = gfc_typenode_for_spec (&class_ts);
+  var = gfc_create_var (tmp, "class");
+
+  /* Set the vptr.  */
+  ctree =  gfc_class_vptr_get (var);
+
+  vtab = gfc_find_intrinsic_vtab (&e->ts);
+  gcc_assert (vtab);
+  tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
+  gfc_add_modify (&parmse->pre, ctree,
+		  fold_convert (TREE_TYPE (ctree), tmp));
+
+  /* Now set the data field.  */
+  ctree =  gfc_class_data_get (var);
+  if (parmse->ss && parmse->ss->info->useflags)
+    {
+      /* For an array reference in an elemental procedure call we need
+	 to retain the ss to provide the scalarized array reference.  */
+      gfc_conv_expr_reference (parmse, e);
+      tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+      gfc_add_modify (&parmse->pre, ctree, tmp);
+    }
+  else
+    {
+      ss = gfc_walk_expr (e);
+      if (ss == gfc_ss_terminator)
+	{
+	  parmse->ss = NULL;
+	  gfc_conv_expr_reference (parmse, e);
+	  tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
+	  gfc_add_modify (&parmse->pre, ctree, tmp);
+	}
+      else
+	{
+	  parmse->ss = ss;
+	  gfc_conv_expr_descriptor (parmse, e);
+	  gfc_add_modify (&parmse->pre, ctree, parmse->expr);
+	}
+    }
+
+  /* Pass the address of the class object.  */
+  parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
+}
+
+
 /* Takes a scalarized class array expression and returns the
    address of a temporary scalar class object of the 'declared'
-   type.  
+   type.
    OOP-TODO: This could be improved by adding code that branched on
    the dynamic type being the same as the declared type. In this case
    the original class expression can be passed directly.
@@ -567,7 +626,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
 
   tmp = NULL_TREE;
   if (class_ref == NULL
-	&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) 
+	&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
     tmp = e->symtree->n.sym->backend_decl;
   else
     {
@@ -813,6 +872,8 @@ gfc_trans_class_init_assign (gfc_code *code)
       gfc_conv_expr (&src, rhs);
       gfc_conv_expr (&memsz, sz);
       gfc_add_block_to_block (&block, &src.pre);
+      src.expr = gfc_build_addr_expr (NULL_TREE, src.expr);
+
       tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr);
     }
 
@@ -826,7 +887,7 @@ gfc_trans_class_init_assign (gfc_code *code)
     }
 
   gfc_add_expr_to_block (&block, tmp);
-  
+
   return gfc_finish_block (&block);
 }
 
@@ -867,10 +928,19 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
       lhs = gfc_copy_expr (expr1);
       gfc_add_vptr_component (lhs);
 
+      if (UNLIMITED_POLY (expr1)
+	  && expr2->expr_type == EXPR_NULL && expr2->ts.type == BT_UNKNOWN)
+	{
+	  rhs = gfc_get_null_expr (&expr2->where);
+ 	  goto assign_vptr;
+	}
+
       if (expr2->ts.type == BT_DERIVED)
 	vtab = gfc_find_derived_vtab (expr2->ts.u.derived);
       else if (expr2->expr_type == EXPR_NULL)
 	vtab = gfc_find_derived_vtab (expr1->ts.u.derived);
+      else
+	vtab = gfc_find_intrinsic_vtab (&expr2->ts);
       gcc_assert (vtab);
 
       rhs = gfc_get_expr ();
@@ -878,13 +948,21 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op)
       gfc_find_sym_tree (vtab->name, vtab->ns, 1, &st);
       rhs->symtree = st;
       rhs->ts = vtab->ts;
-
+assign_vptr:
       tmp = gfc_trans_pointer_assignment (lhs, rhs);
       gfc_add_expr_to_block (&block, tmp);
 
       gfc_free_expr (lhs);
       gfc_free_expr (rhs);
     }
+  else if (expr1->ts.type == BT_DERIVED && UNLIMITED_POLY (expr2))
+    {
+      /* F2003:C717 only sequence and bind-C types can come here.  */
+      gcc_assert (expr1->ts.u.derived->attr.sequence
+		  || expr1->ts.u.derived->attr.is_bind_c);
+      gfc_add_data_component (expr2);
+      goto assign;
+    }
   else if (CLASS_DATA (expr2)->attr.dimension)
     {
       /* Insert an additional assignment which sets the '_vptr' field.  */
@@ -1110,7 +1188,7 @@ gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts, int kind)
       tmp = gfc_get_int_type (kind);
       tmp = fold_convert (tmp, build_fold_indirect_ref_loc (input_location,
 							se->expr));
-    
+
       /* Test for a NULL value.  */
       tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
 			tmp, fold_convert (TREE_TYPE (tmp), integer_one_node));
@@ -1147,9 +1225,9 @@ gfc_get_expr_charlen (gfc_expr *e)
   gfc_ref *r;
   tree length;
 
-  gcc_assert (e->expr_type == EXPR_VARIABLE 
+  gcc_assert (e->expr_type == EXPR_VARIABLE
 	      && e->ts.type == BT_CHARACTER);
-  
+
   length = NULL; /* To silence compiler warning.  */
 
   if (is_subref_array (e) && e->ts.u.cl->length)
@@ -1238,8 +1316,8 @@ flatten_array_ctors_without_strlen (gfc_expr* e)
     {
 
     case EXPR_OP:
-      flatten_array_ctors_without_strlen (e->value.op.op1); 
-      flatten_array_ctors_without_strlen (e->value.op.op2); 
+      flatten_array_ctors_without_strlen (e->value.op.op1);
+      flatten_array_ctors_without_strlen (e->value.op.op2);
       break;
 
     case EXPR_COMPCALL:
@@ -1604,7 +1682,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 	se_expr = gfc_get_fake_result_decl (sym, parent_flag);
 
       /* Similarly for alternate entry points.  */
-      else if (alternate_entry 
+      else if (alternate_entry
 	       && (sym->ns->proc_name->backend_decl == current_function_decl
 		   || parent_flag))
 	{
@@ -1640,7 +1718,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 
 
       /* Dereference the expression, where needed. Since characters
-	 are entirely different from other types, they are treated 
+	 are entirely different from other types, they are treated
 	 separately.  */
       if (sym->ts.type == BT_CHARACTER)
 	{
@@ -1670,7 +1748,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 	    se->expr = build_fold_indirect_ref_loc (input_location,
 						se->expr);
 
-	  /* Dereference non-character pointer variables. 
+	  /* Dereference non-character pointer variables.
 	     These must be dummies, results, or scalars.  */
 	  if ((sym->attr.pointer || sym->attr.allocatable
 	       || gfc_is_associate_pointer (sym)
@@ -1828,11 +1906,11 @@ static const unsigned char powi_table[POWI_TABLE_SIZE] =
     124, 166, 125, 214, 126, 138, 127, 153,  /* 248 - 255 */
   };
 
-/* If n is larger than lookup table's max index, we use the "window 
+/* If n is larger than lookup table's max index, we use the "window
    method".  */
 #define POWI_WINDOW_SIZE 3
 
-/* Recursive function to expand the power operator. The temporary 
+/* Recursive function to expand the power operator. The temporary
    values are put in tmpvar. The function returns tmpvar[1] ** n.  */
 static tree
 gfc_conv_powi (gfc_se * se, unsigned HOST_WIDE_INT n, tree * tmpvar)
@@ -1895,7 +1973,7 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs)
   /* There's no ABS for HOST_WIDE_INT, so here we go. It also takes care
      of the asymmetric range of the integer type.  */
   n = (unsigned HOST_WIDE_INT) (m < 0 ? -m : m);
-  
+
   type = TREE_TYPE (lhs);
   sgn = tree_int_cst_sgn (rhs);
 
@@ -2006,7 +2084,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
 	case 4:
 	  ikind = 0;
 	  break;
-	  
+
 	case 8:
 	  ikind = 1;
 	  break;
@@ -2034,7 +2112,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
 	case 4:
 	  kind = 0;
 	  break;
-	  
+
 	case 8:
 	  kind = 1;
 	  break;
@@ -2050,7 +2128,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
 	default:
 	  gcc_unreachable ();
 	}
-      
+
       switch (expr->value.op.op1->ts.type)
 	{
 	case BT_INTEGER:
@@ -2068,7 +2146,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
 		case 0:
 		  fndecl = builtin_decl_explicit (BUILT_IN_POWIF);
 		  break;
-		
+
 		case 1:
 		  fndecl = builtin_decl_explicit (BUILT_IN_POWI);
 		  break;
@@ -2078,7 +2156,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
 		  break;
 
 		case 3:
-		  /* Use the __builtin_powil() only if real(kind=16) is 
+		  /* Use the __builtin_powil() only if real(kind=16) is
 		     actually the C long double type.  */
 		  if (!gfc_real16_is_float128)
 		    fndecl = builtin_decl_explicit (BUILT_IN_POWIL);
@@ -2089,7 +2167,7 @@ gfc_conv_power_op (gfc_se * se, gfc_expr * expr)
 		}
 	    }
 
-	  /* If we don't have a good builtin for this, go for the 
+	  /* If we don't have a good builtin for this, go for the
 	     library function.  */
 	  if (!fndecl)
 	    fndecl = gfor_fndecl_math_powi[kind][ikind].real;
@@ -2497,7 +2575,7 @@ gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr)
 				    (int)(*expr)->value.character.string[0]);
 	  if ((*expr)->ts.kind != gfc_c_int_kind)
 	    {
-  	      /* The expr needs to be compatible with a C int.  If the 
+  	      /* The expr needs to be compatible with a C int.  If the
 		 conversion fails, then the 2 causes an ICE.  */
 	      ts.type = BT_INTEGER;
 	      ts.kind = gfc_c_int_kind;
@@ -2937,8 +3015,8 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping,
   else if (!sym->attr.dimension || sym->attr.pointer || sym->attr.allocatable)
     value = build_fold_indirect_ref_loc (input_location,
 				     se->expr);
-  
-  /* For character(*), use the actual argument's descriptor.  */  
+
+  /* For character(*), use the actual argument's descriptor.  */
   else if (sym->ts.type == BT_CHARACTER && !new_sym->ts.u.cl->length)
     value = build_fold_indirect_ref_loc (input_location,
 				     se->expr);
@@ -3347,7 +3425,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
   rss = gfc_walk_expr (expr);
 
   gcc_assert (rss != gfc_ss_terminator);
- 
+
   /* Initialize the scalarizer.  */
   gfc_init_loopinfo (&loop);
   gfc_add_ss_to_loop (&loop, rss);
@@ -3507,7 +3585,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
 
   tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false, true);
   gfc_add_expr_to_block (&body, tmp);
-  
+
   /* Generate the copying loops.  */
   gfc_trans_scalarizing_loops (&loop2, &body);
 
@@ -3534,7 +3612,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
   if (formal_ptr)
     {
       size = gfc_index_one_node;
-      offset = gfc_index_zero_node;  
+      offset = gfc_index_zero_node;
       for (n = 0; n < dimen; n++)
 	{
 	  tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
@@ -3635,7 +3713,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
 	    && !(fsym->attr.pointer || fsym->attr.allocatable)
 	    && fsym->as->type != AS_ASSUMED_SHAPE;
 	  f = f || !sym->attr.always_explicit;
-      
+
 	  gfc_conv_array_parameter (se, arg->expr, f, NULL, NULL, NULL);
 	}
 
@@ -3654,7 +3732,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
       arg->expr->ts.f90_type = sym->ts.u.derived->ts.f90_type;
       arg->expr->ts.kind = sym->ts.u.derived->ts.kind;
       gfc_conv_expr_reference (se, arg->expr);
-  
+
       return 1;
     }
   else if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
@@ -3756,14 +3834,14 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
 				       gfc_array_index_type, stride,
 				       fold_convert (gfc_array_index_type,
 						     shapese.expr)));
-      /* Finish scalarization loop.  */ 
+      /* Finish scalarization loop.  */
       gfc_trans_scalarizing_loops (&loop, &body);
       gfc_add_block_to_block (&block, &loop.pre);
       gfc_add_block_to_block (&block, &loop.post);
       gfc_add_block_to_block (&block, &fptrse.post);
       gfc_cleanup_loop (&loop);
 
-      gfc_add_modify (&block, offset, 
+      gfc_add_modify (&block, offset,
 		      fold_build1_loc (input_location, NEGATE_EXPR,
 				       gfc_array_index_type, offset));
       gfc_conv_descriptor_offset_set (&block, desc, offset);
@@ -3796,7 +3874,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
 	{
 	  tree eq_expr;
 	  tree not_null_expr;
-	  
+
 	  /* Given two arguments so build the arg2se from second arg.  */
 	  gfc_init_se (&arg2se, NULL);
 	  gfc_conv_expr (&arg2se, arg->next->expr);
@@ -3820,7 +3898,7 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
 
       return 1;
     }
-    
+
   /* Nothing was done.  */
   return 0;
 }
@@ -3994,6 +4072,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				     CLASS_DATA (fsym)->attr.class_pointer
 				     || CLASS_DATA (fsym)->attr.allocatable);
 	}
+      else if (UNLIMITED_POLY (fsym) && e->ts.type != BT_CLASS)
+	{
+	  /* The intrinsic type needs to be converted to a temporary
+	     CLASS object for the unlimited polymorphic formal.  */
+	  gfc_init_se (&parmse, se);
+	  gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
+	}
       else if (se->ss && se->ss->info->useflags)
 	{
 	  gfc_ss *ss;
@@ -4051,7 +4136,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		= fold_build3_loc (input_location, COND_EXPR,
 				   TREE_TYPE (parmse.expr),
 				   gfc_unlikely (tmp),
-				   fold_convert (TREE_TYPE (parmse.expr), 
+				   fold_convert (TREE_TYPE (parmse.expr),
 						 null_pointer_node),
 				   parmse.expr);
 	    }
@@ -4192,7 +4277,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				     CLASS_DATA (fsym)->attr.class_pointer
 				     || CLASS_DATA (fsym)->attr.allocatable);
 
-		  /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
+		  /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
 		     allocated on entry, it must be deallocated.  */
 		  if (fsym && fsym->attr.intent == INTENT_OUT
 		      && (fsym->attr.allocatable
@@ -4205,7 +4290,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 		      gfc_init_block  (&block);
 		      ptr = parmse.expr;
 		      if (e->ts.type == BT_CLASS)
-			ptr = gfc_class_data_get (ptr);	
+			ptr = gfc_class_data_get (ptr);
 
 		      tmp = gfc_deallocate_with_status (ptr, NULL_TREE,
 							NULL_TREE, NULL_TREE,
@@ -4327,7 +4412,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
 	      /* If the argument is a function call that may not create
 		 a temporary for the result, we have to check that we
-		 can do it, i.e. that there is no alias between this 
+		 can do it, i.e. that there is no alias between this
 		 argument and another one.  */
 	      if (gfc_get_noncopying_intrinsic_argument (e) != NULL)
 		{
@@ -4387,7 +4472,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      else
 	        gfc_conv_array_parameter (&parmse, e, f, fsym, sym->name, NULL);
 
-	      /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is 
+	      /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
 		 allocated on entry, it must be deallocated.  */
 	      if (fsym && fsym->attr.allocatable
 		  && fsym->attr.intent == INTENT_OUT)
@@ -4404,7 +4489,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				       tmp, build_empty_stmt (input_location));
 		  gfc_add_expr_to_block (&se->pre, tmp);
 		}
-	    } 
+	    }
 	}
 
       /* The case with fsym->attr.optional is that of a user subroutine
@@ -4430,7 +4515,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      && ((e->rank != 0 && sym->attr.elemental)
 		  || e->representation.length || e->ts.type == BT_CHARACTER
 		  || (e->rank != 0
-		      && (fsym == NULL 
+		      && (fsym == NULL
 			  || (fsym-> as
 			      && (fsym->as->type == AS_ASSUMED_SHAPE
 				  || fsym->as->type == AS_ASSUMED_RANK
@@ -4600,7 +4685,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 				      fold_convert (TREE_TYPE (tmp),
 						    null_pointer_node));
 	    }
- 
+
 	  gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where,
 				   msg);
 	  free (msg);
@@ -4618,8 +4703,21 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	}
 
       /* Character strings are passed as two parameters, a length and a
-         pointer - except for Bind(c) which only passes the pointer.  */
-      if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
+	 pointer - except for Bind(c) which only passes the pointer.
+	 An unlimited polymorphic formal argument likewise does not
+	 need the length.  */
+      if (parmse.string_length != NULL_TREE
+	  && !sym->attr.is_bind_c
+	  && !(fsym && UNLIMITED_POLY (fsym)))
+	vec_safe_push (stringargs, parmse.string_length);
+
+      /* When calling __copy for character expressions to unlimited
+	 polymorphic entities, the dst argument needs a string length.  */
+      if (sym->name[0] == '_' && e && e->ts.type == BT_CHARACTER
+	  && strncmp (sym->name, "__vtab_CHARACTER", 16) == 0
+	  && arg->next && arg->next->expr
+	  && arg->next->expr->ts.type == BT_DERIVED
+	  && arg->next->expr->ts.u.derived->attr.unlimited_polymorphic)
 	vec_safe_push (stringargs, parmse.string_length);
 
       /* For descriptorless coarrays and assumed-shape coarray dummies, we
@@ -4656,7 +4754,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 			  && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
 	      tmp = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type);
 	    }
-	  
+
 	  vec_safe_push (stringargs, tmp);
 
 	  if (GFC_DESCRIPTOR_TYPE_P (caf_type)
@@ -4752,7 +4850,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	    gfc_conv_expr (&parmse, ts.u.cl->length);
 	  gfc_add_block_to_block (&se->pre, &parmse.pre);
 	  gfc_add_block_to_block (&se->post, &parmse.post);
-	  
+
 	  tmp = fold_convert (gfc_charlen_type_node, parmse.expr);
 	  tmp = fold_build2_loc (input_location, MAX_EXPR,
 				 gfc_charlen_type_node, tmp,
@@ -5490,7 +5588,7 @@ gfc_conv_array_constructor_expr (gfc_se * se, gfc_expr * expr)
 
 
 /* Build a static initializer.  EXPR is the expression for the initial value.
-   The other parameters describe the variable of the component being 
+   The other parameters describe the variable of the component being
    initialized. EXPR may be null.  */
 
 tree
@@ -5521,7 +5619,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
       gcc_assert (TREE_CODE (se.expr) != CONSTRUCTOR);
       return se.expr;
     }
-  
+
   if (array && !procptr)
     {
       tree ctor;
@@ -5557,7 +5655,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
 	case BT_CLASS:
 	  gfc_init_se (&se, NULL);
 	  if (ts->type == BT_CLASS && expr->expr_type == EXPR_NULL)
-	    gfc_conv_structure (&se, gfc_class_null_initializer(ts), 1);
+	    gfc_conv_structure (&se, gfc_class_null_initializer(ts, expr), 1);
 	  else
 	    gfc_conv_structure (&se, expr, 1);
 	  gcc_assert (TREE_CODE (se.expr) == CONSTRUCTOR);
@@ -5579,7 +5677,7 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
 	}
     }
 }
-  
+
 static tree
 gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
 {
@@ -5626,7 +5724,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
 	       cm->as->lower[n]->value.integer);
       mpz_add_ui (lss_array->shape[n], lss_array->shape[n], 1);
     }
-  
+
   /* Associate the SS with the loop.  */
   gfc_add_ss_to_loop (&loop, lss);
   gfc_add_ss_to_loop (&loop, rss);
@@ -5691,7 +5789,7 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
   gfc_start_block (&block);
   gfc_init_se (&se, NULL);
 
-  /* Get the descriptor for the expressions.  */ 
+  /* Get the descriptor for the expressions.  */
   se.want_pointer = 0;
   gfc_conv_expr_descriptor (&se, expr);
   gfc_add_block_to_block (&block, &se.pre);
@@ -5867,7 +5965,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
     {
       /* NULL initialization for CLASS components.  */
       tmp = gfc_trans_structure_assign (dest,
-					gfc_class_null_initializer (&cm->ts));
+					gfc_class_null_initializer (&cm->ts, expr));
       gfc_add_expr_to_block (&block, tmp);
     }
   else if (cm->attr.dimension && !cm->attr.proc_pointer)
@@ -5948,7 +6046,7 @@ gfc_trans_structure_assign (tree dest, gfc_expr * expr)
 		      fold_convert (TREE_TYPE (lse.expr), se.expr));
 
       return gfc_finish_block (&block);
-    } 
+    }
 
   for (c = gfc_constructor_first (expr->value.constructor);
        c; c = gfc_constructor_next (c), cm = cm->next)
@@ -6004,13 +6102,9 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
       if (!c->expr || (cm->attr.allocatable && cm->attr.flavor != FL_PROCEDURE))
         continue;
 
-      if (strcmp (cm->name, "_size") == 0)
-	{
-	  val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
-	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
-	}
-      else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
-	       && strcmp (cm->name, "_extends") == 0)
+      if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
+	  && strcmp (cm->name, "_extends") == 0
+	  && cm->initializer->symtree)
 	{
 	  tree vtab;
 	  gfc_symbol *vtabs;
@@ -6018,6 +6112,11 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
 	  vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
 	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
 	}
+      else if (cm->ts.u.derived && strcmp (cm->name, "_size") == 0)
+	{
+	  val = TYPE_SIZE_UNIT (gfc_get_derived_type (cm->ts.u.derived));
+	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+	}
       else
 	{
 	  val = gfc_conv_initializer (c->expr, &cm->ts,
@@ -6030,7 +6129,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
 	}
     }
   se->expr = build_constructor (type, v);
-  if (init) 
+  if (init)
     TREE_CONSTANT (se->expr) = 1;
 }
 
@@ -6309,7 +6408,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
   scalar = ss == gfc_ss_terminator;
   if (!scalar)
     gfc_free_ss_chain (ss);
- 
+
   if (scalar)
     {
       /* Scalar pointers.  */
@@ -6794,7 +6893,7 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
 
   /* Functions returning pointers or allocatables need temporaries.  */
   c = expr2->value.function.esym
-      ? (expr2->value.function.esym->attr.pointer 
+      ? (expr2->value.function.esym->attr.pointer
 	 || expr2->value.function.esym->attr.allocatable)
       : (expr2->symtree->n.sym->attr.pointer
 	 || expr2->symtree->n.sym->attr.allocatable);
@@ -7085,7 +7184,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
      correctly take care of the reallocation internally. For intrinsic
      calls, the array data is freed and the library takes care of allocation.
      TODO: Add logic of trans-array.c: gfc_alloc_allocatable_for_assignment
-     to the library.  */    
+     to the library.  */
   if (gfc_option.flag_realloc_lhs
 	&& gfc_is_reallocatable_lhs (expr1)
 	&& !gfc_expr_attr (expr1).codimension
@@ -7417,7 +7516,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
   gfc_init_se (&lse, NULL);
   lse.want_pointer = 1;
   gfc_conv_expr (&lse, expr1);
-  
+
   jump_label1 = gfc_build_label_decl (NULL_TREE);
   jump_label2 = gfc_build_label_decl (NULL_TREE);