re PR fortran/64324 (Deferred character specific functions not permitted in generic operator interface)

2016-01-15  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/64324
	* resolve.c (check_uop_procedure): Prevent deferred length
	characters from being trapped by assumed length error.

	PR fortran/49630
	PR fortran/54070
	PR fortran/60593
	PR fortran/60795
	PR fortran/61147
	PR fortran/64324
	* trans-array.c (gfc_conv_scalarized_array_ref): Pass decl for
	function as well as variable expressions.
	(gfc_array_init_size): Add 'expr' as an argument. Use this to
	correctly set the descriptor dtype for deferred characters.
	(gfc_array_allocate): Add 'expr' to the call to
	'gfc_array_init_size'.
	* trans.c (gfc_build_array_ref): Expand logic for setting span
	to include indirect references to character lengths.
	* trans-decl.c (gfc_get_symbol_decl): Ensure that deferred
	result char lengths that are PARM_DECLs are indirectly
	referenced both for directly passed and by reference.
	(create_function_arglist): If the length type is a pointer type
	then store the length as the 'passed_length' and make the char
	length an indirect reference to it.
	(gfc_trans_deferred_vars): If a character length has escaped
	being set as an indirect reference, return it via the 'passed
	length'.
	* trans-expr.c (gfc_conv_procedure_call): The length of
	deferred character length results is set TREE_STATIC and set to
	zero.
	(gfc_trans_assignment_1): Do not fix the rse string_length if
	it is a variable, a parameter or an indirect reference. Add the
	code to trap assignment of scalars to unallocated arrays.
	* trans-stmt.c (gfc_trans_allocate): Remove 'def_str_len' and
	all references to it. Instead, replicate the code to obtain a
	explicitly defined string length and provide a value before
	array allocation so that the dtype is correctly set.
	trans-types.c (gfc_get_character_type): If the character length
	is a pointer, use the indirect reference.

2016-01-15  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/49630
	* gfortran.dg/deferred_character_13.f90: New test for the fix
	of comment 3 of the PR.

	PR fortran/54070
	* gfortran.dg/deferred_character_8.f90: New test
	* gfortran.dg/allocate_error_5.f90: New test

	PR fortran/60593
	* gfortran.dg/deferred_character_10.f90: New test

	PR fortran/60795
	* gfortran.dg/deferred_character_14.f90: New test

	PR fortran/61147
	* gfortran.dg/deferred_character_11.f90: New test

	PR fortran/64324
	* gfortran.dg/deferred_character_9.f90: New test

From-SVN: r232450

8 files changed, 146 insertions, 29 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 051c6ed..5ad05ce 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,45 @@
+2016-01-15  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/64324
+	* resolve.c (check_uop_procedure): Prevent deferred length
+	characters from being trapped by assumed length error.
+
+	PR fortran/49630
+	PR fortran/54070
+	PR fortran/60593
+	PR fortran/60795
+	PR fortran/61147
+	PR fortran/64324
+	* trans-array.c (gfc_conv_scalarized_array_ref): Pass decl for
+	function as well as variable expressions.
+	(gfc_array_init_size): Add 'expr' as an argument. Use this to
+	correctly set the descriptor dtype for deferred characters.
+	(gfc_array_allocate): Add 'expr' to the call to
+	'gfc_array_init_size'.
+	* trans.c (gfc_build_array_ref): Expand logic for setting span
+	to include indirect references to character lengths.
+	* trans-decl.c (gfc_get_symbol_decl): Ensure that deferred
+	result char lengths that are PARM_DECLs are indirectly
+	referenced both for directly passed and by reference.
+	(create_function_arglist): If the length type is a pointer type
+	then store the length as the 'passed_length' and make the char
+	length an indirect reference to it.
+	(gfc_trans_deferred_vars): If a character length has escaped
+	being set as an indirect reference, return it via the 'passed
+	length'.
+	* trans-expr.c (gfc_conv_procedure_call): The length of
+	deferred character length results is set TREE_STATIC and set to
+	zero.
+	(gfc_trans_assignment_1): Do not fix the rse string_length if
+	it is a variable, a parameter or an indirect reference. Add the
+	code to trap assignment of scalars to unallocated arrays.
+	* trans-stmt.c (gfc_trans_allocate): Remove 'def_str_len' and
+	all references to it. Instead, replicate the code to obtain a
+	explicitly defined string length and provide a value before
+	array allocation so that the dtype is correctly set.
+	trans-types.c (gfc_get_character_type): If the character length
+	is a pointer, use the indirect reference.
+
 2016-01-10  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
 	PR fortran/69154
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 2c839f9..64d59ce 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -15320,9 +15320,9 @@ check_uop_procedure (gfc_symbol *sym, locus where)
     }
 
   if (sym->ts.type == BT_CHARACTER
-      && !(sym->ts.u.cl && sym->ts.u.cl->length)
-      && !(sym->result && sym->result->ts.u.cl
-	   && sym->result->ts.u.cl->length))
+      && !((sym->ts.u.cl && sym->ts.u.cl->length) || sym->ts.deferred)
+      && !(sym->result && ((sym->result->ts.u.cl
+	   && sym->result->ts.u.cl->length) || sym->result->ts.deferred)))
     {
       gfc_error ("User operator procedure %qs at %L cannot be assumed "
 		 "character length", sym->name, &where);
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index a46f103..eeb688c 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3165,7 +3165,8 @@ gfc_conv_scalarized_array_ref (gfc_se * se, gfc_array_ref * ar)
 			     index, info->offset);
 
   if (expr && (is_subref_array (expr)
-	       || (expr->ts.deferred && expr->expr_type == EXPR_VARIABLE)))
+	       || (expr->ts.deferred && (expr->expr_type == EXPR_VARIABLE
+					 || expr->expr_type == EXPR_FUNCTION))))
     decl = expr->symtree->n.sym->backend_decl;
 
   tmp = build_fold_indirect_ref_loc (input_location, info->data);
@@ -5038,7 +5039,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
 		     gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
 		     stmtblock_t * descriptor_block, tree * overflow,
 		     tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
-		     tree expr3_desc, bool e3_is_array_constr)
+		     tree expr3_desc, bool e3_is_array_constr, gfc_expr *expr)
 {
   tree type;
   tree tmp;
@@ -5063,8 +5064,19 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
   offset = gfc_index_zero_node;
 
   /* Set the dtype.  */
-  tmp = gfc_conv_descriptor_dtype (descriptor);
-  gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (type));
+  if (expr->ts.type == BT_CHARACTER && expr->ts.deferred
+      && TREE_CODE (expr->ts.u.cl->backend_decl) == VAR_DECL)
+    {
+      type = gfc_typenode_for_spec (&expr->ts);
+      tmp = gfc_conv_descriptor_dtype (descriptor);
+      gfc_add_modify (descriptor_block, tmp,
+		      gfc_get_dtype_rank_type (rank, type));
+    }
+  else
+    {
+      tmp = gfc_conv_descriptor_dtype (descriptor);
+      gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (type));
+    }
 
   or_expr = boolean_false_node;
 
@@ -5446,7 +5458,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
 			      ref->u.ar.as->corank, &offset, lower, upper,
 			      &se->pre, &set_descriptor_block, &overflow,
 			      expr3_elem_size, nelems, expr3, e3_arr_desc,
-			      e3_is_array_constr);
+			      e3_is_array_constr, expr);
 
   if (dimension)
     {
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 929cbda..a0305a6 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1377,8 +1377,8 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 	&& TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
     {
       sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
-      sym->ts.u.cl->backend_decl = NULL_TREE;
-      length = gfc_create_string_length (sym);
+      gcc_assert (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length)));
+      sym->ts.u.cl->backend_decl = build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
     }
 
   fun_or_res = byref && (sym->attr.result
@@ -1420,9 +1420,12 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 		  /* We need to insert a indirect ref for param decls.  */
 		  if (sym->ts.u.cl->backend_decl
 		      && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)
+		    {
+		      sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
 		    sym->ts.u.cl->backend_decl =
 			build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
 		}
+		}
 	      /* For all other parameters make sure, that they are copied so
 		 that the value and any modifications are local to the routine
 		 by generating a temporary variable.  */
@@ -1431,6 +1434,10 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 		       && sym->ts.u.cl->backend_decl)
 		{
 		  sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl;
+		  if (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length)))
+		    sym->ts.u.cl->backend_decl
+			= build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
+		  else
 		  sym->ts.u.cl->backend_decl = NULL_TREE;
 		}
 	    }
@@ -2264,6 +2271,13 @@ create_function_arglist (gfc_symbol * sym)
 	      type = gfc_sym_type (arg);
 	      arg->backend_decl = backend_decl;
 	      type = build_reference_type (type);
+
+	      if (POINTER_TYPE_P (len_type))
+		{
+		  sym->ts.u.cl->passed_length = length;
+		  sym->ts.u.cl->backend_decl =
+		    build_fold_indirect_ref_loc (input_location, length);
+		}
 	    }
 	}
 
@@ -2347,7 +2361,10 @@ create_function_arglist (gfc_symbol * sym)
 	  if (f->sym->ts.u.cl->backend_decl == NULL
 	      || f->sym->ts.u.cl->backend_decl == length)
 	    {
-	      if (f->sym->ts.u.cl->backend_decl == NULL)
+	      if (POINTER_TYPE_P (len_type))
+		f->sym->ts.u.cl->backend_decl =
+			build_fold_indirect_ref_loc (input_location, length);
+	      else if (f->sym->ts.u.cl->backend_decl == NULL)
 		gfc_create_string_length (f->sym);
 
 	      /* Make sure PARM_DECL type doesn't point to incomplete type.  */
@@ -3975,12 +3992,19 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 	      gfc_restore_backend_locus (&loc);
 
 	      /* Pass back the string length on exit.  */
+	      tmp = proc_sym->ts.u.cl->backend_decl;
+	      if (TREE_CODE (tmp) != INDIRECT_REF)
+		{
 	      tmp = proc_sym->ts.u.cl->passed_length;
 	      tmp = build_fold_indirect_ref_loc (input_location, tmp);
 	      tmp = fold_convert (gfc_charlen_type_node, tmp);
 	      tmp = fold_build2_loc (input_location, MODIFY_EXPR,
 				     gfc_charlen_type_node, tmp,
 				     proc_sym->ts.u.cl->backend_decl);
+		}
+	      else
+		tmp = NULL_TREE;
+
 	      gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
 	    }
 	  else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 1a6b734..863e2aa 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5942,6 +5942,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  tmp = len;
 	  if (TREE_CODE (tmp) != VAR_DECL)
 	    tmp = gfc_evaluate_now (len, &se->pre);
+	  TREE_STATIC (tmp) = 1;
+	  gfc_add_modify (&se->pre, tmp,
+			  build_int_cst (TREE_TYPE (tmp), 0));
 	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
 	  vec_safe_push (retargs, tmp);
 	}
@@ -9263,7 +9266,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
     }
 
   /* Stabilize a string length for temporaries.  */
-  if (expr2->ts.type == BT_CHARACTER && !expr2->ts.deferred)
+  if (expr2->ts.type == BT_CHARACTER && !expr1->ts.deferred
+      && !(TREE_CODE (rse.string_length) == VAR_DECL
+	   || TREE_CODE (rse.string_length) == PARM_DECL
+	   || TREE_CODE (rse.string_length) == INDIRECT_REF))
     string_length = gfc_evaluate_now (rse.string_length, &rse.pre);
   else if (expr2->ts.type == BT_CHARACTER)
     string_length = rse.string_length;
@@ -9277,7 +9283,32 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 	lse.string_length = string_length;
     }
   else
+    {
     gfc_conv_expr (&lse, expr1);
+      if (gfc_option.rtcheck & GFC_RTCHECK_MEM
+	  && gfc_expr_attr (expr1).allocatable
+	  && expr1->rank
+	  && !expr2->rank)
+	{
+	  tree cond;
+	  const char* msg;
+
+	  tmp = expr1->symtree->n.sym->backend_decl;
+	  if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+	    tmp = build_fold_indirect_ref_loc (input_location, tmp);
+
+	  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+	    tmp = gfc_conv_descriptor_data_get (tmp);
+	  else
+	    tmp = TREE_OPERAND (lse.expr, 0);
+
+	  cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+				  tmp, build_int_cst (TREE_TYPE (tmp), 0));
+	  msg = _("Assignment of scalar to unallocated array");
+	  gfc_trans_runtime_check (true, false, cond, &loop.pre,
+				   &expr1->where, msg);
+	}
+    }
 
   /* Assignments of scalar derived types with allocatable components
      to arrays must be done with a deep copy and the rhs temporary
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 70a61cc..310d2cd 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1437,7 +1437,7 @@ gfc_trans_critical (gfc_code *code)
 			  tree_cons (NULL_TREE, tmp, NULL_TREE),
 			  NULL_TREE);
       ASM_VOLATILE_P (tmp) = 1;
-  
+
       gfc_add_expr_to_block (&block, tmp);
     }
 
@@ -5298,7 +5298,6 @@ gfc_trans_allocate (gfc_code * code)
   tree label_finish;
   tree memsz;
   tree al_vptr, al_len;
-  tree def_str_len = NULL_TREE;
   /* If an expr3 is present, then store the tree for accessing its
      _vptr, and _len components in the variables, respectively.  The
      element size, i.e. _vptr%size, is stored in expr3_esize.  Any of
@@ -5688,7 +5687,6 @@ gfc_trans_allocate (gfc_code * code)
 	  expr3_esize = fold_build2_loc (input_location, MULT_EXPR,
 					 TREE_TYPE (se_sz.expr),
 					 tmp, se_sz.expr);
-	  def_str_len = gfc_evaluate_now (se_sz.expr, &block);
 	}
     }
 
@@ -5741,16 +5739,6 @@ gfc_trans_allocate (gfc_code * code)
       se.want_pointer = 1;
       se.descriptor_only = 1;
 
-      if (expr->ts.type == BT_CHARACTER
-	  && expr->ts.deferred
-	  && TREE_CODE (expr->ts.u.cl->backend_decl) == VAR_DECL
-	  && def_str_len != NULL_TREE)
-	{
-	  tmp = expr->ts.u.cl->backend_decl;
-	  gfc_add_modify (&block, tmp,
-			  fold_convert (TREE_TYPE (tmp), def_str_len));
-	}
-
       gfc_conv_expr (&se, expr);
       if (expr->ts.type == BT_CHARACTER && expr->ts.deferred)
 	/* se.string_length now stores the .string_length variable of expr
@@ -5888,6 +5876,20 @@ gfc_trans_allocate (gfc_code * code)
 	      /* Prevent setting the length twice.  */
 	      al_len_needs_set = false;
 	    }
+	  else if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE
+		   && code->ext.alloc.ts.u.cl->length)
+	    {
+	      /* Cover the cases where a string length is explicitly
+		 specified by a type spec for deferred length character
+		 arrays or unlimited polymorphic objects without a
+		 source= or mold= expression.  */
+	      gfc_init_se (&se_sz, NULL);
+	      gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length);
+	      gfc_add_modify (&block, al_len,
+			      fold_convert (TREE_TYPE (al_len),
+					    se_sz.expr));
+	      al_len_needs_set = false;
+	    }
 	}
 
       gfc_add_block_to_block (&block, &se.pre);
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 12cce4d..f3d0841 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1045,6 +1045,8 @@ gfc_get_character_type (int kind, gfc_charlen * cl)
   tree len;
 
   len = (cl == NULL) ? NULL_TREE : cl->backend_decl;
+  if (len && POINTER_TYPE_P (TREE_TYPE (len)))
+    len = build_fold_indirect_ref (len);
 
   return gfc_get_character_type_len (kind, len);
 }
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 44b85e8..e71430b 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -335,10 +335,13 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
      references.  */
   if (type && TREE_CODE (type) == ARRAY_TYPE
       && TYPE_MAXVAL (TYPE_DOMAIN (type)) != NULL_TREE
-      && TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == VAR_DECL
+      && (TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == VAR_DECL
+	  || TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == INDIRECT_REF)
       && decl
-      && DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type)))
-					== DECL_CONTEXT (decl))
+      && (TREE_CODE (TYPE_MAXVAL (TYPE_DOMAIN (type))) == INDIRECT_REF
+	  || TREE_CODE (decl) == FUNCTION_DECL
+	  || DECL_CONTEXT (TYPE_MAXVAL (TYPE_DOMAIN (type)))
+					== DECL_CONTEXT (decl)))
     span = TYPE_MAXVAL (TYPE_DOMAIN (type));
   else
     span = NULL_TREE;
@@ -354,7 +357,8 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
      and reference the element with pointer arithmetic.  */
   if ((decl && (TREE_CODE (decl) == FIELD_DECL
 		|| TREE_CODE (decl) == VAR_DECL
-		|| TREE_CODE (decl) == PARM_DECL)
+		|| TREE_CODE (decl) == PARM_DECL
+		|| TREE_CODE (decl) == FUNCTION_DECL)
        && ((GFC_DECL_SUBREF_ARRAY_P (decl)
 	    && !integer_zerop (GFC_DECL_SPAN (decl)))
 	   || GFC_DECL_CLASS (decl)