Commit 0a524296 by Paul Thomas

re PR fortran/90093 (Extended C interop: optional argument incorrectly identified as PRESENT)

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
parent e965aaf6
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
......
......@@ -406,7 +406,7 @@ match_data_constant (gfc_expr **result)
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;
......@@ -1493,19 +1493,18 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
/* 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;
}
}
......@@ -6074,7 +6073,7 @@ static bool
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;
......@@ -6085,7 +6084,7 @@ in_module_or_interface(void)
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;
}
......@@ -6304,7 +6303,7 @@ gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
}
if (gfc_match_char (')') == MATCH_YES)
{
{
if (typeparam)
{
gfc_error_now ("A type parameter list is required at %C");
......@@ -7489,7 +7488,7 @@ gfc_match_entry (void)
if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
&(entry->declared_at), 1))
return MATCH_ERROR;
}
if (!gfc_current_ns->parent
......
......@@ -1239,6 +1239,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
tree nelem;
tree cond;
tree or_expr;
tree elemsize;
tree class_expr = NULL_TREE;
int n, dim, tmp_dim;
int total_dim = 0;
......@@ -1333,15 +1334,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
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:
......@@ -1413,22 +1405,21 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
}
}
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);
}
......@@ -1438,6 +1429,10 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
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);
......@@ -7248,6 +7243,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
if (se->force_tmp)
need_tmp = 1;
else if (se->force_no_tmp)
need_tmp = 0;
if (need_tmp)
full = 0;
......
......@@ -4278,8 +4278,10 @@ convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
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,
......@@ -4303,6 +4305,12 @@ convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
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,
......@@ -4318,16 +4326,43 @@ convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
/* 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);
......@@ -4923,9 +4958,9 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
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);
}
......
......@@ -5006,6 +5006,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
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,
......
......@@ -290,6 +290,16 @@ get_array_span (tree type, tree decl)
{
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
......@@ -352,9 +362,6 @@ get_array_span (tree type, tree decl)
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;
......@@ -399,12 +406,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
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. */
......
......@@ -91,6 +91,9 @@ typedef struct gfc_se
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
......@@ -305,7 +321,7 @@
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>
......
/* 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;
}
! { 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
......@@ -24,4 +24,4 @@ end
! 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" } }
! { 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
......@@ -61,4 +61,4 @@ 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" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment