1 files changed, 104 insertions, 32 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 52a532d2408..52d37039753 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -281,7 +281,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
       se->string_length = tmp;
     }
 
-  if (c->pointer && c->dimension == 0)
+  if (c->pointer && c->dimension == 0 && c->ts.type != BT_CHARACTER)
     se->expr = gfc_build_indirect_ref (se->expr);
 }
 
@@ -356,27 +356,41 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 	  return;
 	}
 
-      /* Dereference scalar dummy variables.  */
-      if (sym->attr.dummy
-	  && sym->ts.type != BT_CHARACTER
-	  && !sym->attr.dimension)
-	se->expr = gfc_build_indirect_ref (se->expr);
-
-      /* Dereference scalar hidden result.  */
-      if (gfc_option.flag_f2c 
-	  && (sym->attr.function || sym->attr.result)
-	  && sym->ts.type == BT_COMPLEX
-	  && !sym->attr.dimension)
-	se->expr = gfc_build_indirect_ref (se->expr);
-
-      /* Dereference pointer variables.  */
-      if ((sym->attr.pointer || sym->attr.allocatable)
-	  && (sym->attr.dummy
-	      || sym->attr.result
-	      || sym->attr.function
-	      || !sym->attr.dimension)
-          && sym->ts.type != BT_CHARACTER)
-	se->expr = gfc_build_indirect_ref (se->expr);
+
+      /* Dereference the expression, where needed. Since characters
+	 are entirely different from other types, they are treated 
+	 separately.  */
+      if (sym->ts.type == BT_CHARACTER)
+	{
+          /* Dereference character pointer dummy arguments
+	     or results.  */
+	  if ((sym->attr.pointer || sym->attr.allocatable)
+	      && (sym->attr.dummy
+		  || sym->attr.function
+		  || sym->attr.result))
+	    se->expr = gfc_build_indirect_ref (se->expr);
+	}
+      else
+	{
+          /* Dereference non-character scalar dummy arguments.  */
+	  if (sym->attr.dummy && !sym->attr.dimension)
+	    se->expr = gfc_build_indirect_ref (se->expr);
+
+          /* Dereference scalar hidden result.  */
+	  if (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX
+	      && (sym->attr.function || sym->attr.result)
+	      && !sym->attr.dimension)
+	    se->expr = gfc_build_indirect_ref (se->expr);
+
+          /* Dereference non-character pointer variables. 
+	     These must be dummies, results, or scalars.  */
+	  if ((sym->attr.pointer || sym->attr.allocatable)
+	      && (sym->attr.dummy
+		  || sym->attr.function
+		  || sym->attr.result
+		  || !sym->attr.dimension))
+	    se->expr = gfc_build_indirect_ref (se->expr);
+	}
 
       ref = expr->ref;
     }
@@ -1083,6 +1097,15 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   var = NULL_TREE;
   len = NULL_TREE;
 
+  /* Obtain the string length now because it is needed often below.  */
+  if (sym->ts.type == BT_CHARACTER)
+    {
+      gcc_assert (sym->ts.cl && sym->ts.cl->length
+		  && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
+      len = gfc_conv_mpz_to_tree
+	      (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
+    }
+
   if (se->ss != NULL)
     {
       if (!sym->attr.elemental)
@@ -1097,6 +1120,9 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
               /* Access the previously obtained result.  */
               gfc_conv_tmp_array_ref (se);
               gfc_advance_se_ss_chain (se);
+
+	      /* Bundle in the string length.  */
+	      se->string_length = len;
               return;
             }
 	}
@@ -1108,14 +1134,26 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   byref = gfc_return_by_reference (sym);
   if (byref)
     {
-      if (se->direct_byref)
-	arglist = gfc_chainon_list (arglist, se->expr);
+      if (se->direct_byref) 
+	{
+	  arglist = gfc_chainon_list (arglist, se->expr);
+
+	  /* Add string length to argument list.  */
+	  if (sym->ts.type == BT_CHARACTER)
+	    {
+	      sym->ts.cl->backend_decl = len;
+	      arglist = gfc_chainon_list (arglist, 
+				convert (gfc_charlen_type_node, len));
+	    }
+	}
       else if (sym->result->attr.dimension)
 	{
 	  gcc_assert (se->loop && se->ss);
+
 	  /* Set the type of the array.  */
 	  tmp = gfc_typenode_for_spec (&sym->ts);
 	  info->dimen = se->loop->dimen;
+
 	  /* Allocate a temporary to store the result.  */
 	  gfc_trans_allocate_temp_array (se->loop, info, tmp);
 
@@ -1124,22 +1162,46 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 	    gfc_conv_descriptor_stride (info->descriptor, gfc_rank_cst[0]);
 	  gfc_add_modify_expr (&se->pre, tmp,
 			       convert (TREE_TYPE (tmp), integer_zero_node));
+
 	  /* Pass the temporary as the first argument.  */
 	  tmp = info->descriptor;
 	  tmp = gfc_build_addr_expr (NULL, tmp);
 	  arglist = gfc_chainon_list (arglist, tmp);
+
+	  /* Add string length to argument list.  */
+	  if (sym->ts.type == BT_CHARACTER)
+	    {
+	      sym->ts.cl->backend_decl = len;
+	      arglist = gfc_chainon_list (arglist, 
+			      convert (gfc_charlen_type_node, len));
+	    }
+
 	}
       else if (sym->ts.type == BT_CHARACTER)
 	{
-	  gcc_assert (sym->ts.cl && sym->ts.cl->length
-		  && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
-	  len = gfc_conv_mpz_to_tree
-	    (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
+
+	  /* Pass the string length.  */
 	  sym->ts.cl->backend_decl = len;
 	  type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
 	  type = build_pointer_type (type);
 
-	  var = gfc_conv_string_tmp (se, type, len);
+	  /* Return an address to a char[0:len-1]* temporary for character pointers.  */
+	  if (sym->attr.pointer || sym->attr.allocatable)
+	    {
+	      /* Build char[0:len-1] * pstr.  */
+	      tmp = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, len,
+				 build_int_cst (gfc_charlen_type_node, 1));
+	      tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
+	      tmp = build_array_type (gfc_character1_type_node, tmp);
+	      var = gfc_create_var (build_pointer_type (tmp), "pstr");
+
+	      /* Provide an address expression for the function arguments.  */
+	      var = gfc_build_addr_expr (NULL, var);
+	    }
+	  else
+	    {
+	      var = gfc_conv_string_tmp (se, type, len);
+	    }
 	  arglist = gfc_chainon_list (arglist, var);
 	  arglist = gfc_chainon_list (arglist, 
 				      convert (gfc_charlen_type_node, len));
@@ -1205,8 +1267,8 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 		  && arg->expr->expr_type != EXPR_NULL)
                 {
                   /* Scalar pointer dummy args require an extra level of
-                     indirection. The null pointer already contains
-		     this level of indirection.  */
+		  indirection. The null pointer already contains
+		  this level of indirection.  */
                   parmse.expr = gfc_build_addr_expr (NULL, parmse.expr);
                 }
             }
@@ -1299,10 +1361,17 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 		  gfc_trans_runtime_check (tmp, gfc_strconst_fault, &se->pre);
 		}
 	      se->expr = info->descriptor;
+	      /* Bundle in the string length.  */
+	      se->string_length = len;
 	    }
 	  else if (sym->ts.type == BT_CHARACTER)
 	    {
-	      se->expr = var;
+	      /* Dereference for character pointer results.  */
+	      if (sym->attr.pointer || sym->attr.allocatable)
+		se->expr = gfc_build_indirect_ref (var);
+	      else
+	        se->expr = var;
+
 	      se->string_length = len;
 	    }
 	  else
@@ -1603,6 +1672,9 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
   gfc_start_scalarized_body (&loop, &body);
 
   gfc_conv_tmp_array_ref (&lse);
+  if (cm->ts.type == BT_CHARACTER)
+    lse.string_length = cm->ts.cl->backend_decl;
+
   gfc_conv_expr (&rse, expr);
 
   tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts.type);