diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 3e3d717fe90..ac72fb2ceae 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2007-12-16 Tobias Burnus + + 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 * 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 e33df0fe0bb..53cd7e64450 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 f0dbd3027e1..2d10ddad080 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 dd3ce1f30fc..d915cdac8d1 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2007-12-16 Tobias Burnus + + PR fortran/34246 + * gfortran.dg/bind_c_usage_16.f03: Extend test. + 2007-12-16 Paul Thomas 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 b05faa752fa..990918fcc59 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