2013-01-06 Tobias Burnus PR fortran/55758 * resolve.c (resolve_symbol): Reject non-C_Bool logicals in BIND(C) procedures with -std=f*. * trans-types.c (gfc_sym_type): Use a non-BOOLEAN_TYPE integer for non-C_Bool logicals in BIND(C) procedures. * trans-expr.c (gfc_conv_unary_op): Add fold convert for INTRINSIC_NOT. (gfc_conv_procedure_call): Convert type-precision != 1 logicals to type-precision == 1. 2013-01-06 Tobias Burnus PR fortran/55758 * gfortran.dg/bind_c_bool_1.f90: New. * gfortran.dg/bind_c_bool_2.f90: New. * gfortran.dg/bind_c_bool_2_c.c: New. * gfortran.dg/bind_c_bool_3.f90: New. * gfortran.dg/do_5.f90: Add dg-warning. diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 54ac3c6..0403396 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -13658,6 +13662,32 @@ resolve_symbol (gfc_symbol *sym) return; } + if (sym->ts.type == BT_LOGICAL + && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym) + || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name + && sym->ns->proc_name->attr.is_bind_c))) + { + int i; + for (i = 0; gfc_logical_kinds[i].kind; i++) + if (gfc_logical_kinds[i].kind == sym->ts.kind) + break; + if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy + && gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument '%s' at %L " + "with non-C_Bool kind in BIND(C) procedure '%s'", + sym->name, &sym->declared_at, + sym->ns->proc_name->name) == FAILURE) + return; + else if (!gfc_logical_kinds[i].c_bool + && gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable '%s' at" + " %L with non-C_Bool kind in BIND(C) " + "procedure '%s'", sym->name, + &sym->declared_at, + sym->attr.function ? sym->name + : sym->ns->proc_name->name) + == FAILURE) + return; + } + switch (sym->attr.flavor) { case FL_VARIABLE: diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 01d3595..59a0ab4 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1850,7 +1850,8 @@ gfc_conv_unary_op (enum tree_code code, gfc_se * se, gfc_expr * expr) We must convert it to a compare to 0 (e.g. EQ_EXPR (op1, 0)). All other unary operators have an equivalent GIMPLE unary operator. */ if (code == TRUTH_NOT_EXPR) - se->expr = fold_build2_loc (input_location, EQ_EXPR, type, operand.expr, + se->expr = fold_build2_loc (input_location, EQ_EXPR, type, + fold_convert (type, operand.expr), build_int_cst (type, 0)); else se->expr = fold_build1_loc (input_location, code, type, operand.expr); @@ -4208,6 +4209,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } else gfc_conv_expr (&parmse, e); + + /* Special case: non-kind=C_BOOL LOGICALs of BIND(C) are + integer types and have to be converted to Booleans. */ + if (e->ts.type == BT_LOGICAL + && TYPE_PRECISION (TREE_TYPE (parmse.expr)) != 1) + parmse.expr + = fold_convert (gfc_get_logical_type (e->ts.kind), + parmse.expr); } else if (arg->name && arg->name[0] == '%') /* Argument list functions %VAL, %LOC and %REF are signalled @@ -4260,6 +4269,28 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, base_object = build_fold_indirect_ref_loc (input_location, parmse.expr); + /* Special case: non-kind=C_BOOL LOGICALs of BIND(C) are + integer types and have to be converted to Booleans. */ + if (e->ts.type == BT_LOGICAL + && TYPE_PRECISION (TREE_TYPE (TREE_TYPE (parmse.expr))) + != 1) + { + tmp = build_fold_indirect_ref_loc (input_location, + parmse.expr); + parmse.expr + = gfc_create_var (gfc_get_logical_type (e->ts.kind), + NULL); + gfc_add_modify_loc (input_location, &se->pre, parmse.expr, + fold_convert (gfc_get_logical_type (e->ts.kind), + tmp)); + if (e->expr_type == EXPR_VARIABLE + && (!fsym || fsym->attr.intent != INTENT_IN + || fsym->attr.pointer)) + gfc_add_modify_loc (input_location, &se->post, tmp, + fold_convert (TREE_TYPE (tmp), parmse.expr)); + parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); + } + /* A class array element needs converting back to be a class object, if the formal argument is a class object. */ if (fsym && fsym->ts.type == BT_CLASS diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 8394bf9..73ed5aa 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2128,6 +2128,25 @@ gfc_sym_type (gfc_symbol * sym) && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c))) type = gfc_character1_type_node; + else if (sym->ts.type == BT_LOGICAL + && ((sym->attr.function && sym->attr.is_bind_c) + || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name + && sym->ns->proc_name->attr.is_bind_c))) + { + /* For LOGICAL dummy arguments or result value of a C binding procedure, + which do not match _Bool (C_Bool kind), a normal integer variable + is used instead of a BOOLEAN_TYPE with a TYPE_PRECISION of 1. The + reason is that on the C side, a normal integer such as "int" is used, + implying that any integer value could be used - not only 0 and 1. */ + int i; + for (i = 0; gfc_logical_kinds[i].kind; i++) + if (gfc_logical_kinds[i].kind == sym->ts.kind) + break; + if (!gfc_logical_kinds[i].c_bool) + type = gfc_get_int_type (sym->ts.kind); + else + type = gfc_typenode_for_spec (&sym->ts); + } else type = gfc_typenode_for_spec (&sym->ts); diff --git a/gcc/testsuite/gfortran.dg/bind_c_bool_1.f90 b/gcc/testsuite/gfortran.dg/bind_c_bool_1.f90 new file mode 100644 index 0000000..467bdc1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_bool_1.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/55758 +! + +function sub2() bind(C) ! { dg-error "GNU Extension: LOGICAL result variable 'sub2' at .1. with non-C_Bool kind in BIND.C. procedure 'sub2'" } + logical(kind=8) :: sub2 + logical(kind=4) :: local ! OK +end function sub2 + +function sub4() bind(C) result(res) ! { dg-error "GNU Extension: LOGICAL result variable 'res' at .1. with non-C_Bool kind in BIND.C. procedure 'sub4'" } + logical(kind=2) :: res + logical(kind=4) :: local ! OK +end function sub4 + + +subroutine sub(x) bind(C) ! { dg-error "GNU Extension: LOGICAL dummy argument 'x' at .1. with non-C_Bool kind in BIND.C. procedure 'sub'" } + logical(kind=4) :: x +end subroutine sub + +subroutine sub3(y) bind(C) + use iso_c_binding, only : c_bool + logical(kind=c_bool) :: y ! OK +end subroutine sub3 diff --git a/gcc/testsuite/gfortran.dg/bind_c_bool_2.f90 b/gcc/testsuite/gfortran.dg/bind_c_bool_2.f90 new file mode 100644 index 0000000..1feb28d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_bool_2.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-options "" } +! { dg-additional-sources bind_c_bool_2_c.c } +! +! PR fortran/55758 +! +! Ensure that logical(c_int) in a BIND(C) function is properly handled, +! i.e. ".not.-1" is not "-2" but 0 as a C programmer would expect. +! + +program main + use iso_c_binding, only : c_int, c_bool + implicit none + logical(4) :: result + + interface + function C_true() bind(C, name="C_true") + import :: c_int + logical(c_int) :: C_true ! { dg-warning "C kind type parameter is for type INTEGER but type at .1. is LOGICAL" } + end function C_true + end interface + + if (c_int == c_bool) stop + + result = C_true() + if (result .neqv. .true.) call abort () + if (transfer(result, 0) /= 1) call abort() + + result = .not.C_true() + if (transfer(result, 0) /= 0) call abort() + if (result .neqv. .false.) call abort () +end program main diff --git a/gcc/testsuite/gfortran.dg/bind_c_bool_2_c.c b/gcc/testsuite/gfortran.dg/bind_c_bool_2_c.c new file mode 100644 index 0000000..3673bdc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_bool_2_c.c @@ -0,0 +1,7 @@ +/* To be used by bind_c_bool_2.f90. PR fortran/55758 */ + +int +C_true (void) +{ + return -1; +} diff --git a/gcc/testsuite/gfortran.dg/bind_c_bool_3.f90 b/gcc/testsuite/gfortran.dg/bind_c_bool_3.f90 new file mode 100644 index 0000000..a73bf6e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bind_c_bool_3.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! { dg-options "" } +! +! PR fortran/55758 +! +! Ensure that a BIND(C) non-C_BOOL LOGICAL with TYPE_PRECISION != 1 is +! correctly converted into a Fortran LOGICAL with TYPE_PRECSION == 1 in +! Procedure calls. +! + +subroutine bar3(x) + logical(kind=4) :: x + logical(kind=4) :: y + y = .not.x + !print *, y, transfer(x,0) + if (y .or. .not. x) call abort() + x = .true. +end subroutine bar3 + +module m +contains +subroutine foo(x) bind(C) + integer :: i + logical(kind=4) :: x + i = -1 + x = transfer(i,.true._4) + call bar(x) + + x = transfer(i,.true._4) + call bar2(x) + if (transfer (x, 1) /= 1) call abort() + + x = transfer(i,.true._4) + call bar3(x) + if (transfer (x, 1) /= 1) call abort() +end subroutine foo + +subroutine bar(x) + logical(kind=4), value :: x + logical(kind=4) :: y + y = .not.x + !print *, y, transfer(x,0) + if (y .or. .not. x) call abort() + x = .true. +end subroutine bar + +subroutine bar2(x) + logical(kind=4) :: x + logical(kind=4) :: y + y = .not.x + if (y .or. .not. x) call abort() + !print *, y, transfer(x,0) +end subroutine bar2 +end + +use m +logical(kind=4) :: x +call foo(x) +end diff --git a/gcc/testsuite/gfortran.dg/do_5.f90 b/gcc/testsuite/gfortran.dg/do_5.f90 index 08cd8e6..9272d87 100644 --- a/gcc/testsuite/gfortran.dg/do_5.f90 +++ b/gcc/testsuite/gfortran.dg/do_5.f90 @@ -15,7 +15,7 @@ L = .FALSE. END FUNCTION - LOGICAL(8) FUNCTION L2() BIND(C) + LOGICAL(8) FUNCTION L2() BIND(C) ! { dg-error "GNU Extension: LOGICAL result variable 'l2' at .1. with non-C_Bool kind in BIND.C. procedure 'l2'" } L2 = .FALSE._8 END FUNCTION