2019-05-10 Paul Thomas <pault@gcc.gnu.org>
PR fortran/90093
* trans-decl.c (convert_CFI_desc): Test that the dummy is
present before doing any of the conversions.
PR fortran/90352
* decl.c (gfc_verify_c_interop_param): Restore the error for
charlen > 1 actual arguments passed to bind(C) procs.
Clean up trailing white space.
PR fortran/90355
* trans-array.c (gfc_trans_create_temp_array): Set the 'span'
field to the element length for all types.
(gfc_conv_expr_descriptor): The force_no_tmp flag is used to
prevent temporary creation, especially for substrings.
* trans-decl.c (gfc_trans_deferred_vars): Rather than assert
that the backend decl for the string length is non-null, use it
as a condition before calling gfc_trans_vla_type_sizes.
* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): 'force_no_tmp'
is set before calling gfc_conv_expr_descriptor.
* trans.c (get_array_span): Move the code for extracting 'span'
from gfc_build_array_ref to this function. This is specific to
descriptors that are component and indirect references.
* trans.h : Add the force_no_tmp flag bitfield to gfc_se.
2019-05-10 Paul Thomas <pault@gcc.gnu.org>
PR fortran/90093
* gfortran.dg/ISO_Fortran_binding_12.f90: New test.
* gfortran.dg/ISO_Fortran_binding_12.c: Supplementary code.
PR fortran/90352
* gfortran.dg/iso_c_binding_char_1.f90: New test.
PR fortran/90355
* gfortran.dg/ISO_Fortran_binding_4.f90: Add 'substr' to test
the direct passing of substrings as descriptors to bind(C).
* gfortran.dg/assign_10.f90: Increase the tree_dump count of
'atmp' to account for the setting of the 'span' field.
* gfortran.dg/transpose_optimization_2.f90: Ditto.
From-SVN: r271057
+2019-05-10 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/90093
+ * trans-decl.c (convert_CFI_desc): Test that the dummy is
+ present before doing any of the conversions.
+
+ PR fortran/90352
+ * decl.c (gfc_verify_c_interop_param): Restore the error for
+ charlen > 1 actual arguments passed to bind(C) procs.
+ Clean up trailing white space.
+
+ PR fortran/90355
+ * trans-array.c (gfc_trans_create_temp_array): Set the 'span'
+ field to the element length for all types.
+ (gfc_conv_expr_descriptor): The force_no_tmp flag is used to
+ prevent temporary creation, especially for substrings.
+ * trans-decl.c (gfc_trans_deferred_vars): Rather than assert
+ that the backend decl for the string length is non-null, use it
+ as a condition before calling gfc_trans_vla_type_sizes.
+ * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): 'force_no_tmp'
+ is set before calling gfc_conv_expr_descriptor.
+ * trans.c (get_array_span): Move the code for extracting 'span'
+ from gfc_build_array_ref to this function. This is specific to
+ descriptors that are component and indirect references.
+ * trans.h : Add the force_no_tmp flag bitfield to gfc_se.
+
2019-05-08 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/90351
contains the right constant expression. Check here. */
if ((*result)->symtree == NULL
&& (*result)->expr_type == EXPR_CONSTANT
- && ((*result)->ts.type == BT_INTEGER
+ && ((*result)->ts.type == BT_INTEGER
|| (*result)->ts.type == BT_REAL))
return m;
/* Character strings are only C interoperable if they have a
length of 1. */
- if (sym->ts.type == BT_CHARACTER)
+ if (sym->ts.type == BT_CHARACTER && !sym->attr.dimension)
{
gfc_charlen *cl = sym->ts.u.cl;
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
|| mpz_cmp_si (cl->length->value.integer, 1) != 0)
{
- if (!gfc_notify_std (GFC_STD_F2018,
- "Character argument %qs at %L "
- "must be length 1 because "
- "procedure %qs is BIND(C)",
- sym->name, &sym->declared_at,
- sym->ns->proc_name->name))
- retval = false;
+ gfc_error ("Character argument %qs at %L "
+ "must be length 1 because "
+ "procedure %qs is BIND(C)",
+ sym->name, &sym->declared_at,
+ sym->ns->proc_name->name);
+ retval = false;
}
}
in_module_or_interface(void)
{
if (gfc_current_state () == COMP_MODULE
- || gfc_current_state () == COMP_SUBMODULE
+ || gfc_current_state () == COMP_SUBMODULE
|| gfc_current_state () == COMP_INTERFACE)
return true;
gfc_state_data *p;
for (p = gfc_state_stack->previous; p ; p = p->previous)
{
- if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE
+ if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE
|| p->state == COMP_INTERFACE)
return true;
}
}
if (gfc_match_char (')') == MATCH_YES)
- {
+ {
if (typeparam)
{
gfc_error_now ("A type parameter list is required at %C");
if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
&(entry->declared_at), 1))
return MATCH_ERROR;
-
+
}
if (!gfc_current_ns->parent
tree nelem;
tree cond;
tree or_expr;
+ tree elemsize;
tree class_expr = NULL_TREE;
int n, dim, tmp_dim;
int total_dim = 0;
tmp = gfc_conv_descriptor_dtype (desc);
gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
- /* Also set the span for derived types, since they can be used in
- component references to arrays of this type. */
- if (TREE_CODE (eltype) == RECORD_TYPE)
- {
- tmp = TYPE_SIZE_UNIT (eltype);
- tmp = fold_convert (gfc_array_index_type, tmp);
- gfc_conv_descriptor_span_set (pre, desc, tmp);
- }
-
/*
Fill in the bounds and stride. This is a packed array, so:
}
}
+ if (class_expr == NULL_TREE)
+ elemsize = fold_convert (gfc_array_index_type,
+ TYPE_SIZE_UNIT (gfc_get_element_type (type)));
+ else
+ elemsize = gfc_class_vtab_size_get (class_expr);
+
/* Get the size of the array. */
if (size && !callee_alloc)
{
- tree elemsize;
/* If or_expr is true, then the extent in at least one
dimension is zero and the size is set to zero. */
size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
or_expr, gfc_index_zero_node, size);
nelem = size;
- if (class_expr == NULL_TREE)
- elemsize = fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type)));
- else
- elemsize = gfc_class_vtab_size_get (class_expr);
-
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, elemsize);
}
size = NULL_TREE;
}
+ /* Set the span. */
+ tmp = fold_convert (gfc_array_index_type, elemsize);
+ gfc_conv_descriptor_span_set (pre, desc, tmp);
+
gfc_trans_allocate_array_storage (pre, post, info, size, nelem, initial,
dynamic, dealloc);
if (se->force_tmp)
need_tmp = 1;
+ else if (se->force_no_tmp)
+ need_tmp = 0;
if (need_tmp)
full = 0;
tree CFI_desc_ptr;
tree dummy_ptr;
tree tmp;
+ tree present;
tree incoming;
tree outgoing;
+ stmtblock_t outer_block;
stmtblock_t tmpblock;
/* dummy_ptr will be the pointer to the passed array descriptor,
gfc_desc_ptr = gfc_create_var (tmp, "gfc_desc_ptr");
CFI_desc_ptr = gfc_create_var (pvoid_type_node, "CFI_desc_ptr");
+ /* Fix the condition for the presence of the argument. */
+ gfc_init_block (&outer_block);
+ present = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, dummy_ptr,
+ build_int_cst (TREE_TYPE (dummy_ptr), 0));
+
gfc_init_block (&tmpblock);
/* Pointer to the gfc descriptor. */
gfc_add_modify (&tmpblock, gfc_desc_ptr,
/* Set the dummy pointer to point to the gfc_descriptor. */
gfc_add_modify (&tmpblock, dummy_ptr,
fold_convert (TREE_TYPE (dummy_ptr), gfc_desc_ptr));
- incoming = gfc_finish_block (&tmpblock);
- gfc_init_block (&tmpblock);
+ /* The hidden string length is not passed to bind(C) procedures so set
+ it from the descriptor element length. */
+ if (sym->ts.type == BT_CHARACTER
+ && sym->ts.u.cl->backend_decl
+ && VAR_P (sym->ts.u.cl->backend_decl))
+ {
+ tmp = build_fold_indirect_ref_loc (input_location, dummy_ptr);
+ tmp = gfc_conv_descriptor_elem_len (tmp);
+ gfc_add_modify (&tmpblock, sym->ts.u.cl->backend_decl,
+ fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
+ tmp));
+ }
+
+ /* Check that the argument is present before executing the above. */
+ incoming = build3_v (COND_EXPR, present,
+ gfc_finish_block (&tmpblock),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&outer_block, incoming);
+ incoming = gfc_finish_block (&outer_block);
+
+
/* Convert the gfc descriptor back to the CFI type before going
- out of scope. */
+ out of scope, if the CFI type was present at entry. */
+ gfc_init_block (&outer_block);
+ gfc_init_block (&tmpblock);
+
tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
outgoing = build_call_expr_loc (input_location,
gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr);
gfc_add_expr_to_block (&tmpblock, outgoing);
- outgoing = gfc_finish_block (&tmpblock);
+
+ outgoing = build3_v (COND_EXPR, present,
+ gfc_finish_block (&tmpblock),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&outer_block, outgoing);
+ outgoing = gfc_finish_block (&outer_block);
/* Add the lot to the procedure init and finally blocks. */
gfc_add_init_cleanup (block, incoming, outgoing);
for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
{
- if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
+ if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER
+ && f->sym->ts.u.cl->backend_decl)
{
- gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)
gfc_trans_vla_type_sizes (f->sym, &tmpblock);
}
if (e->rank != 0)
{
+ parmse->force_no_tmp = 1;
if (fsym->attr.contiguous
&& !gfc_is_simply_contiguous (e, false, true))
gfc_conv_subref_array_arg (parmse, e, false, fsym->attr.intent,
{
tree span;
+ /* Component references are guaranteed to have a reliable value for
+ 'span'. Likewise indirect references since they emerge from the
+ conversion of a CFI descriptor or the hidden dummy descriptor. */
+ if (TREE_CODE (decl) == COMPONENT_REF
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+ return gfc_conv_descriptor_span_get (decl);
+ else if (TREE_CODE (decl) == INDIRECT_REF
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+ return gfc_conv_descriptor_span_get (decl);
+
/* Return the span for deferred character length array references. */
if (type && TREE_CODE (type) == ARRAY_TYPE
&& TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE
else
span = NULL_TREE;
}
- else if (TREE_CODE (decl) == INDIRECT_REF
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
- span = gfc_conv_descriptor_span_get (decl);
else
span = NULL_TREE;
if (vptr)
span = gfc_vptr_size_get (vptr);
else if (decl)
- {
- if (TREE_CODE (decl) == COMPONENT_REF)
- span = gfc_conv_descriptor_span_get (decl);
- else
- span = get_array_span (type, decl);
- }
+ span = get_array_span (type, decl);
/* If a non-null span has been generated reference the element with
pointer arithmetic. */
args alias. */
unsigned force_tmp:1;
+ /* If set, will pass subref descriptors without a temporary. */
+ unsigned force_no_tmp:1;
+
/* Unconditionally calculate offset for array segments and constant
arrays in gfc_conv_expr_descriptor. */
unsigned use_offset:1;
+2019-05-10 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/90093
+ * gfortran.dg/ISO_Fortran_binding_12.f90: New test.
+ * gfortran.dg/ISO_Fortran_binding_12.c: Supplementary code.
+
+ PR fortran/90352
+ * gfortran.dg/iso_c_binding_char_1.f90: New test.
+
+ PR fortran/90355
+ * gfortran.dg/ISO_Fortran_binding_4.f90: Add 'substr' to test
+ the direct passing of substrings as descriptors to bind(C).
+ * gfortran.dg/assign_10.f90: Increase the tree_dump count of
+ 'atmp' to account for the setting of the 'span' field.
+ * gfortran.dg/transpose_optimization_2.f90: Ditto.
+
2019-05-10 Jakub Jelinek <jakub@redhat.com>
PR tree-optimization/88709
PR fortran/60144
* gfortran.dg/block_name_2.f90: Adjust dg-error.
* gfortran.dg/dec_type_print_3.f90.f90: Likewise
- * gfortran.dg/pr60144.f90: New test.
+ * gfortran.dg/pr60144.f90: New test.
2019-05-01 Jeff Law <law@redhat.com>
--- /dev/null
+/* Test the fix for PR90093. */
+
+#include <stdio.h>
+#include <math.h>
+#include "../../../libgfortran/ISO_Fortran_binding.h"
+
+/* Contributed by Reinhold Bader <Bader@lrz.de> */
+
+void foo_opt(CFI_cdesc_t *, float *, int *, int);
+void write_res();
+
+float x[34];
+
+int main() {
+ CFI_CDESC_T(1) xd;
+ CFI_index_t ext[] = {34};
+ int sz;
+
+ CFI_establish((CFI_cdesc_t *) &xd, &x, CFI_attribute_other,
+ CFI_type_float, 0, 1, ext);
+
+ foo_opt((CFI_cdesc_t *) &xd, NULL, NULL, 0);
+ sz = 12;
+ foo_opt(NULL, &x[11], &sz, 1);
+
+ write_res();
+
+ return 0;
+}
--- /dev/null
+! { dg-do run { target c99_runtime } }
+! { dg-additional-sources ISO_Fortran_binding_12.c }
+!
+! Test the fix for PR90093. The additional source is the main program.
+!
+! Contributed by Reinhold Bader <Bader@lrz.de>
+!
+module mod_optional
+ use, intrinsic :: iso_c_binding
+ implicit none
+ integer :: status = 0
+
+contains
+
+ subroutine foo_opt(this, that, sz, flag) bind(c)
+ real(c_float), optional :: this(:)
+ real(c_float), optional :: that(*)
+ integer(c_int), optional :: sz
+ integer(c_int), value :: flag
+ if (flag == 0) then
+ if (.not. present(this) .or. present(that) .or. present(sz)) then
+ write(*,*) 'FAIL 1', present(this), present(that), present(sz)
+ status = status + 1
+ end if
+ else if (flag == 1) then
+ if (present(this) .or. .not. present(that) .or. .not. present(sz)) then
+ write(*,*) 'FAIL 2', present(this), present(that), present(sz)
+ status = status + 1
+ end if
+ if (sz /= 12) then
+ write(*,*) 'FAIL 3'
+ status = status + 1
+ end if
+ else if (flag == 2) then
+ if (present(this) .or. present(that) .or. present(sz)) then
+ write(*,*) 'FAIL 4', present(this), present(that), present(sz)
+ status = status + 1
+ end if
+ end if
+ end subroutine foo_opt
+
+ subroutine write_res() BIND(C)
+! Add a check that the fortran missing optional is accepted by the
+! bind(C) procedure.
+ call foo_opt (flag = 2)
+ if (status == 0) then
+ write(*,*) 'OK'
+ else
+ stop 1
+ end if
+ end subroutine
+
+end module mod_optional
! { dg-do run }
! PR fortran/89384 - this used to give a wrong results
! with contiguous.
+! The subroutine substr is a test to check a problem found while
+! debugging PR90355.
+!
! Test case by Reinhold Bader.
+!
module mod_ctg
implicit none
+
contains
+
subroutine ctg(x) BIND(C)
real, contiguous :: x(:)
-
- if (any(abs(x - [2.,4.,6.]) > 1.e-6)) then
- write(*,*) 'FAIL'
- stop 1
- else
- write(*,*) 'OK'
- end if
+ if (any(abs(x - [2.,4.,6.]) > 1.e-6)) stop 1
x = [2.,4.,6.]*10.0
end subroutine
+
+ subroutine substr(str) BIND(C)
+ character(*) :: str(:)
+ if (str(2) .ne. "ghi") stop 2
+ str = ['uvw','xyz']
+ end subroutine
+
end module
+
program p
use mod_ctg
implicit none
real :: x(6)
+ character(5) :: str(2) = ['abcde','fghij']
integer :: i
x = [ (real(i), i=1, size(x)) ]
call ctg(x(2::2))
- if (any (abs (x - [1.,20.,3.,40.,5.,60.]) > 1.e-6)) stop 2
+ if (any (abs (x - [1.,20.,3.,40.,5.,60.]) > 1.e-6)) stop 3
+
+ call substr(str(:)(2:4))
+ if (any (str .ne. ['auvwe','fxyzj'])) stop 4
end program
! Note that it is the kind conversion that generates the temp.
!
! { dg-final { scan-tree-dump-times "parm" 20 "original" } }
-! { dg-final { scan-tree-dump-times "atmp" 18 "original" } }
+! { dg-final { scan-tree-dump-times "atmp" 20 "original" } }
--- /dev/null
+! { dg-do compile }
+!
+! Test the fix for PR90352.
+!
+! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>
+!
+subroutine bar(c,d) BIND(C) ! { dg-error "must be length 1" }
+ character (len=*) c
+ character (len=2) d
+end
! The check below for temporaries gave 14 and 33 for "parm" and "atmp".
!
! { dg-final { scan-tree-dump-times "parm" 72 "original" } }
-! { dg-final { scan-tree-dump-times "atmp" 12 "original" } }
+! { dg-final { scan-tree-dump-times "atmp" 13 "original" } }
projects / gcc.git / commitdiff