re PR fortran/34246 (gfortran.dg/bind_c_usage_16.f03 doesn't work)

2007-12-16  Tobias Burnus  <burnus@net-b.de>

        PR fortran/34246
        * trans-types.c (gfc_init_types): Change build_type_variant
        to build_qualified_type.
        (gfc_sym_type): Return gfc_character1_type_node for
        character-returning bind(C) functions.
        * trans-expr.c (gfc_conv_function_call): Do not set
        se->string_length for character-returning bind(c) functions.
        (gfc_trans_string_copy,gfc_trans_scalar_assign):
         Support also single characters.

2007-12-16  Tobias Burnus  <burnus@net-b.de>

        PR fortran/34246
        * gfortran.dg/bind_c_usage_16.f03: Extend test.

From-SVN: r130991

5 files changed, 85 insertions, 31 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 3e3d717..ac72fb2 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+2007-12-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34246
+	* trans-types.c (gfc_init_types): Change build_type_variant
+	to build_qualified_type.
+	(gfc_sym_type): Return gfc_character1_type_node for
+	character-returning bind(C) functions.
+	* trans-expr.c (gfc_conv_function_call): Do not set
+	se->string_length for character-returning bind(c) functions.
+	(gfc_trans_string_copy,gfc_trans_scalar_assign):
+	Support also single characters.
+
 2007-12-16  Bernhard Fischer  <aldot@gcc.gnu.org>
 
 	* errors.c (gfc_notify_std): As originally stated but improperly
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e33df0f..53cd7e6 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2559,7 +2559,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
   gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
 
   ts = sym->ts;
-  if (ts.type == BT_CHARACTER)
+  if (ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
     {
       if (sym->ts.cl->length == NULL)
 	{
@@ -2736,15 +2736,6 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
       && !sym->attr.always_explicit)
     se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
 
-  /* Bind(C) character variables may have only length 1.  */
-  if (sym->ts.type == BT_CHARACTER && sym->attr.is_bind_c)
-    {
-      gcc_assert (sym->ts.cl->length
-		  && sym->ts.cl->length->expr_type == EXPR_CONSTANT
-		  && mpz_cmp_si (sym->ts.cl->length->value.integer, 1) == 0);
-      se->string_length = build_int_cst (gfc_charlen_type_node, 1);
-    }
-
   /* A pure function may still have side-effects - it may modify its
      parameters.  */
   TREE_SIDE_EFFECTS (se->expr) = 1;
@@ -2820,12 +2811,34 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
   tree tmp4;
   stmtblock_t tempblock;
 
-  dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
-  slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
+  if (slength != NULL_TREE)
+    {
+      slen = fold_convert (size_type_node, gfc_evaluate_now (slength, block));
+      ssc = gfc_to_single_character (slen, src);
+    }
+  else
+    {
+      slen = build_int_cst (size_type_node, 1);
+      ssc =  src;
+    }
+
+  if (dlength != NULL_TREE)
+    {
+      dlen = fold_convert (size_type_node, gfc_evaluate_now (dlength, block));
+      dsc = gfc_to_single_character (slen, dest);
+    }
+  else
+    {
+      dlen = build_int_cst (size_type_node, 1);
+      dsc =  dest;
+    }
+
+  if (slength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (src)))
+    ssc = gfc_to_single_character (slen, src);
+  if (dlength != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (dest)))
+    dsc = gfc_to_single_character (dlen, dest);
+
 
-  /* Deal with single character specially.  */
-  dsc = gfc_to_single_character (dlen, dest);
-  ssc = gfc_to_single_character (slen, src);
   if (dsc != NULL_TREE && ssc != NULL_TREE)
     {
       gfc_add_modify_expr (block, dsc, ssc);
@@ -2859,8 +2872,15 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
      We're now doing it here for better optimization, but the logic
      is the same.  */
 
-  dest = fold_convert (pvoid_type_node, dest);
-  src = fold_convert (pvoid_type_node, src);
+  if (dlength)
+    dest = fold_convert (pvoid_type_node, dest);
+  else
+    dest = gfc_build_addr_expr (pvoid_type_node, dest);
+
+  if (slength)
+    src = fold_convert (pvoid_type_node, src);
+  else
+    src = gfc_build_addr_expr (pvoid_type_node, src);
 
   /* Truncate string if source is too long.  */
   cond2 = fold_build2 (GE_EXPR, boolean_type_node, slen, dlen);
@@ -3806,17 +3826,25 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
 
   if (ts.type == BT_CHARACTER)
     {
-      gcc_assert (lse->string_length != NULL_TREE
-	      && rse->string_length != NULL_TREE);
+      tree rlen = NULL;
+      tree llen = NULL;
 
-      gfc_conv_string_parameter (lse);
-      gfc_conv_string_parameter (rse);
+      if (lse->string_length != NULL_TREE)
+	{
+	  gfc_conv_string_parameter (lse);
+	  gfc_add_block_to_block (&block, &lse->pre);
+	  llen = lse->string_length;
+	}
 
-      gfc_add_block_to_block (&block, &lse->pre);
-      gfc_add_block_to_block (&block, &rse->pre);
+      if (rse->string_length != NULL_TREE)
+	{
+	  gcc_assert (rse->string_length != NULL_TREE);
+	  gfc_conv_string_parameter (rse);
+	  gfc_add_block_to_block (&block, &rse->pre);
+	  rlen = rse->string_length;
+	}
 
-      gfc_trans_string_copy (&block, lse->string_length, lse->expr,
-			     rse->string_length, rse->expr);
+      gfc_trans_string_copy (&block, llen, lse->expr, rlen, rse->expr);
     }
   else if (ts.type == BT_DERIVED && ts.derived->attr.alloc_comp)
     {
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index f0dbd30..2d10dda 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -717,8 +717,8 @@ gfc_init_types (void)
       PUSH_TYPE (name_buf, type);
     }
 
-  gfc_character1_type_node = build_type_variant (unsigned_char_type_node, 
-						 0, 0);
+  gfc_character1_type_node = build_qualified_type (unsigned_char_type_node, 
+						   TYPE_UNQUALIFIED);
   PUSH_TYPE ("character(kind=1)", gfc_character1_type_node);
 
   PUSH_TYPE ("byte", unsigned_char_type_node);
@@ -1555,7 +1555,11 @@ gfc_sym_type (gfc_symbol * sym)
   if (sym->backend_decl && !sym->attr.function)
     return TREE_TYPE (sym->backend_decl);
 
-  type = gfc_typenode_for_spec (&sym->ts);
+  if (sym->ts.type == BT_CHARACTER && sym->attr.is_bind_c
+      && (sym->attr.function || sym->attr.result))
+    type = gfc_character1_type_node;
+  else
+    type = gfc_typenode_for_spec (&sym->ts);
 
   if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
     byref = 1;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index dd3ce1f..d915cda 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2007-12-16  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34246
+	* gfortran.dg/bind_c_usage_16.f03: Extend test.
+
 2007-12-16  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/31213
diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_16.f03 b/gcc/testsuite/gfortran.dg/bind_c_usage_16.f03
index b05faa7..990918f 100644
--- a/gcc/testsuite/gfortran.dg/bind_c_usage_16.f03
+++ b/gcc/testsuite/gfortran.dg/bind_c_usage_16.f03
@@ -24,9 +24,11 @@ subroutine test() bind(c)
   use mod
   implicit none
   character(len=1,kind=c_char) :: a
-  character(len=5,kind=c_char) :: b
+  character(len=3,kind=c_char) :: b
   character(len=1,kind=c_char) :: c(3)
-  character(len=5,kind=c_char) :: d(3)
+  character(len=3,kind=c_char) :: d(3)
+  integer :: i
+
   a = 'z'
   b = 'fffff'
   c = 'h'
@@ -35,7 +37,7 @@ subroutine test() bind(c)
   a = bar('x')
   if (a /= 'A') call abort()
   b = bar('y')
-  if (b /= 'A') call abort()
+  if (b /= 'A' .or. iachar(b(2:2))/=32 .or. iachar(b(3:3))/=32) call abort()
   c = bar('x')
   if (any(c /= 'A')) call abort()
   d = bar('y')
@@ -49,4 +51,7 @@ subroutine test() bind(c)
   if (any(c /= 'B')) call abort()
   d = foo()
   if (any(d /= 'B')) call abort()
+  do i = 1,3
+    if(iachar(d(i)(2:2)) /=32 .or. iachar(d(i)(3:3)) /= 32) call abort()
+  end do
 end subroutine