procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/89385 (Incorrect members of C descriptor for an allocatable object)

Browse source 
2019-02-23  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/89385
	PR fortran/89366
	* decl.c (gfc_verify_c_interop_param): Restriction on string
	length being one is lifted for F2018.
	* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): For scalar
	characters with intent in, make a temporary and copy the result
	of the expression evaluation into it.
	(gfc_conv_procedure_call): Set a flag for character formal args
	having a character length that is not unity. If the procedure
	is bind C, call gfc_conv_gfc_desc_to_cfi_desc in this case.
	Also, extend bind C calls to unconditionally convert both
	pointers and allocatable expressions.

2019-02-23  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/89385
	* gfortran.dg/ISO_Fortran_binding_1.f90 : Correct test for
	previously incorrect lbound for allocatable expressions. Also
	correct stop values to avoid repetition.
	* gfortran.dg/ISO_Fortran_binding_5.f90 : New test
	* gfortran.dg/ISO_Fortran_binding_5.c : Support previous test.

	PR fortran/89366
	* gfortran.dg/ISO_Fortran_binding_6.f90 : New test
	* gfortran.dg/ISO_Fortran_binding_6.c : Support previous test.
	* gfortran.dg/pr32599.f03 : Set standard to F2008.

2019-02-23  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/89385
	PR fortran/89366
	* runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc) : In the
	interchange between character and derived, the character type
	was being set incorrectly.
	(gfc_desc_to_cfi_desc) : Eliminate the interchange of types in
	this function. Do not add the kind and length information to
	the type field of structures. Lbounds were incorrectly being
	set to zero for allocatable and pointer descriptors. Should
	have been non-pointer, non-allocatables that received this
	treatment.

From-SVN: r269156
This commit is contained in:
Paul Thomas 2019-02-23 12:18:44 +00:00
parent ace857f95d
commit c280838969
12 changed files with 296 additions and 28 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
gcc/fortran/ChangeLog
View file

@ -1,3 +1,18 @@
2019-02-23 Paul Thomas <pault@gcc.gnu.org>
PR fortran/89385
PR fortran/89366
* decl.c (gfc_verify_c_interop_param): Restriction on string
length being one is lifted for F2018.
* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): For scalar
characters with intent in, make a temporary and copy the result
of the expression evaluation into it.
(gfc_conv_procedure_call): Set a flag for character formal args
having a character length that is not unity. If the procedure
is bind C, call gfc_conv_gfc_desc_to_cfi_desc in this case.
Also, extend bind C calls to unconditionally convert both
pointers and allocatable expressions.
2019-02-23 David Malcolm <dmalcolm@redhat.com>
Jakub Jelinek <jakub@redhat.com>

13
gcc/fortran/decl.c
View file

@ -1499,12 +1499,13 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
|| mpz_cmp_si (cl->length->value.integer, 1) != 0)
{
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;
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;
}
}

46
gcc/fortran/trans-expr.c
View file

@ -5012,6 +5012,8 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
gfc_conv_descriptor_data_get (parmse->expr),
size);
gfc_add_expr_to_block (&parmse->pre, tmp);
/* The temporary 'ptr' is freed below. */
gfc_conv_descriptor_data_set (&parmse->pre, parmse->expr, ptr);
}
@ -5026,7 +5028,26 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
/* Copy the scalar for INTENT(IN). */
if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN)
parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
{
if (e->ts.type != BT_CHARACTER)
parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
else
{
/* The temporary string 'ptr' is freed below. */
tmp = build_pointer_type (TREE_TYPE (parmse->expr));
ptr = gfc_create_var (tmp, "str");
tmp = build_call_expr_loc (input_location,
builtin_decl_explicit (BUILT_IN_MALLOC),
1, parmse->string_length);
tmp = fold_convert (TREE_TYPE (ptr), tmp);
gfc_add_modify (&parmse->pre, ptr, tmp);
tmp = gfc_build_memcpy_call (ptr, parmse->expr,
parmse->string_length);
gfc_add_expr_to_block (&parmse->pre, tmp);
parmse->expr = ptr;
}
}
parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
parmse->expr, attr);
}
@ -5188,11 +5209,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
{
bool finalized = false;
bool non_unity_length_string = false;
e = arg->expr;
fsym = formal ? formal->sym : NULL;
parm_kind = MISSING;
if (fsym && fsym->ts.type == BT_CHARACTER && fsym->ts.u.cl
&& (!fsym->ts.u.cl->length
|| fsym->ts.u.cl->length->expr_type != EXPR_CONSTANT
|| mpz_cmp_si (fsym->ts.u.cl->length->value.integer, 1) != 0))
non_unity_length_string = true;
/* If the procedure requires an explicit interface, the actual
argument is passed according to the corresponding formal
argument. If the corresponding formal argument is a POINTER,
@ -5418,9 +5446,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
else if (sym->attr.is_bind_c && e
&& fsym && fsym->attr.dimension
&& (fsym->as->type == AS_ASSUMED_RANK
|| fsym->as->type == AS_ASSUMED_SHAPE))
&& ((fsym && fsym->attr.dimension
&& (fsym->attr.pointer
|| fsym->attr.allocatable
|| fsym->as->type == AS_ASSUMED_RANK
|| fsym->as->type == AS_ASSUMED_SHAPE))
|| non_unity_length_string))
/* Implement F2018, C.12.6.1: paragraph (2). */
gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
@ -5865,8 +5896,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (sym->attr.is_bind_c && e
&& fsym && fsym->attr.dimension
&& (fsym->as->type == AS_ASSUMED_RANK
|| fsym->as->type == AS_ASSUMED_SHAPE))
&& (fsym->attr.pointer
|| fsym->attr.allocatable
|| fsym->as->type == AS_ASSUMED_RANK
|| fsym->as->type == AS_ASSUMED_SHAPE
|| non_unity_length_string))
/* Implement F2018, C.12.6.1: paragraph (2). */
gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);

14
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,17 @@
2019-02-23 Paul Thomas <pault@gcc.gnu.org>
PR fortran/89385
* gfortran.dg/ISO_Fortran_binding_1.f90 : Correct test for
previously incorrect lbound for allocatable expressions. Also
correct stop values to avoid repetition.
* gfortran.dg/ISO_Fortran_binding_5.f90 : New test
* gfortran.dg/ISO_Fortran_binding_5.c : Support previous test.
PR fortran/89366
* gfortran.dg/ISO_Fortran_binding_6.f90 : New test
* gfortran.dg/ISO_Fortran_binding_6.c : Support previous test.
* gfortran.dg/pr32599.f03 : Set standard to F2008.
2019-02-22 David Malcolm <dmalcolm@redhat.com>
PR c++/89390

12
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90
View file

@ -192,7 +192,9 @@ end subroutine test_CFI_address
a = [(real(i), i = 1, 100)]
lower(1) = 10
strides(1) = 5
if (int (sum(a(lower(1)::strides(1))) &
! Remember, 'a' being non pointer, non-allocatable, the C descriptor
! lbounds are set to zero.
if (int (sum(a(lower(1)+1::strides(1))) &
- c_section(1, a, lower, strides)) .ne. 0) stop 28
! Case (ii) from F2018:18.5.5.7.
arg(:,1:10) = reshape ([(real(i), i = 1, 100)], [10,10])
@ -222,7 +224,7 @@ end subroutine test_CFI_address
end do
end do
! Now do the test.
if (int (c_select_part (type_t) - sum_z_5) .ne. 0) stop 28
if (int (c_select_part (type_t) - sum_z_5) .ne. 0) stop 30
end subroutine test_CFI_select_part
subroutine test_CFI_setpointer
@ -232,13 +234,13 @@ end subroutine test_CFI_address
integer, dimension(2) :: lbounds = [-1, -2]
! The C-function resets the lbounds
ptr(1:, 1:) => tgt
if (c_setpointer (ptr, lbounds) .ne. 0) stop 30
if (any (lbound(ptr) .ne. lbounds)) stop 31
if (c_setpointer (ptr, lbounds) .ne. 0) stop 31
if (any (lbound(ptr) .ne. lbounds)) stop 32
end subroutine test_CFI_setpointer
subroutine test_assumed_size (arg)
integer, dimension(2,*) :: arg
! The C-function checks contiguousness and that extent[1] == -1.
if (c_assumed_size (arg) .ne. 0) stop 32
if (c_assumed_size (arg) .ne. 0) stop 33
end subroutine
end

83
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_5.c Normal file
View file

@ -0,0 +1,83 @@
/* Test fix for PR89385. */
/* Contributed by Reinhold Bader <Bader@lrz.de> */
#include <stdio.h>
#include <math.h>
#include "ISO_Fortran_binding.h"
typedef struct {
int i;
float r[2];
} cstruct;
void Psub(CFI_cdesc_t *this, CFI_cdesc_t *that, int *ierr) {
int status = 0;
cstruct *cu;
float *ct;
CFI_dim_t *dim;
if (this->elem_len != sizeof(float)) {
printf("FAIL: this->elem_len %i\n",(int) this->elem_len);
status++;
}
if (this->type != CFI_type_float) {
printf("FAIL: this->type\n");
status++;
}
if (this->rank != 2) {
printf("FAIL: this->rank %i\n",this->rank);
status++;
}
if (this->attribute != CFI_attribute_allocatable) {
printf("FAIL: this->attribute\n");
status++;
}
dim = this->dim;
if (dim[0].lower_bound != 3 || dim[0].extent != 4) {
printf("FAIL: dim[0] %d %d\n", dim[0].lower_bound, dim[0].extent);
status++;
}
if (dim[1].lower_bound != 1 || dim[1].extent != 5) {
printf("FAIL: dim[1] %d %d\n", dim[1].lower_bound, dim[1].extent);
status++;
}
if (that->elem_len != sizeof(cstruct)) {
printf("FAIL: that->elem_len\n");
status++;
}
if (that->type != CFI_type_struct) {
printf("FAIL: that->type %d %d\n", that->type, CFI_type_struct);
status++;
}
if (that->rank != 1) {
printf("FAIL: that->rank\n");
status++;
}
if (that->attribute != CFI_attribute_allocatable) {
printf("FAIL: that->attribute\n");
status++;
}
dim = that->dim;
if (dim[0].lower_bound != 1 || dim[0].extent != 1) {
printf("FAIL: dim[0] %d %d\n" , dim[0].lower_bound, dim[0].extent);
status++;
}
cu = (cstruct *) ((CFI_cdesc_t *) that)->base_addr;
if (cu->i != 4 || fabs(cu->r[1] - 2.2) > 1.0e-6) {
printf("FAIL: value of that %i %f %f\n",cu->i,cu->r[1],cu->r[2]);
status++;
}
ct = (float *) ((CFI_cdesc_t *) this)->base_addr;
if ( fabs(ct[5] + 2.0) > 1.0e-6) {
printf("FAIL: value of this %f\n",ct[5]);
status++;
}
*ierr = status;
}

36
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_5.f90 Normal file
View file

@ -0,0 +1,36 @@
! { dg-do run }
! { dg-additional-sources ISO_Fortran_binding_5.c }
!
! Test fix of PR89385.
!
! Contributed by Reinhold Bader <Bader@lrz.de>
!
program allocatable_01
use, intrinsic :: iso_c_binding
implicit none
type, bind(c) :: cstruct
integer(c_int) :: i
real(c_float) :: r(2)
end type cstruct
interface
subroutine psub(this, that, ierr) bind(c, name='Psub')
import :: c_float, cstruct, c_int
real(c_float), allocatable :: this(:,:)
type(cstruct), allocatable :: that(:)
integer(c_int), intent(inout) :: ierr
end subroutine psub
end interface
real(c_float), allocatable :: t(:,:)
type(cstruct), allocatable :: u(:)
integer(c_int) :: ierr
allocate(t(3:6,5))
t = 0.0
t(4,2) = -2.0
allocate(u(1), source=[ cstruct( 4, [1.1,2.2] ) ] )
call psub(t, u, ierr)
deallocate(t,u)
if (ierr .ne. 0) stop ierr
end program allocatable_01

23
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_6.c Normal file
View file

@ -0,0 +1,23 @@
/* Test fix for PR89366. */
/* Contributed by Reinhold Bader <Bader@lrz.de> */
#include <stdio.h>
#include <math.h>
#include "ISO_Fortran_binding.h"
#define DEBUG 0
void process_string(CFI_cdesc_t *this, int *ierr) {
char *cstr;
cstr = (char *) this->base_addr;
*ierr = 0;
if (this->rank != 0) {
*ierr = 1;
return;
}
if (DEBUG == 1) {
printf("elem_len member has value %i %s\n",this->elem_len, cstr);
}
}

41
gcc/testsuite/gfortran.dg/ISO_Fortran_binding_6.f90 Normal file
View file

@ -0,0 +1,41 @@
! { dg-do run }
! { dg-additional-sources ISO_Fortran_binding_6.c }
!
! Test fix of PR89366.
!
! Contributed by Reinhold Bader <Bader@lrz.de>
!
program assumed_length_01
use, intrinsic :: iso_c_binding
implicit none
integer, parameter :: strlen = 12
integer(c_int) :: ierr(3)
character(kind=c_char,len=strlen) :: s1
character(kind=c_char,len=:), allocatable :: s2
character(kind=c_char,len=:), pointer :: s3
!
! invoke a C function that processes an assumed length string
interface
subroutine process_string(this, ierr) BIND(C)
import :: c_char, c_int
character(kind=c_char,len=*), intent(in) :: this(..)
integer(c_int), intent(inout) :: ierr
end subroutine process_string
end interface
!
!
ierr = 0
s1 = c_char_'wrzlprmft' // c_null_char
call process_string(s1, ierr(1))
if (ierr(1) /= 0) stop 1
s2 = c_char_'wrzlprmft' // c_null_char
allocate(s3, source=trim(s1))
call process_string(s2, ierr(2))
if (ierr(2) /= 0) stop 2
call process_string(s3, ierr(3))
if (ierr(3) /= 0) stop 3
if (sum(abs(ierr)) == 0) write(*,*) 'OK'
deallocate(s2,s3)
end program assumed_length_01

14
gcc/testsuite/gfortran.dg/pr32599.f03
View file

@ -1,26 +1,30 @@
! { dg-do compile }
! { dg-options "-std=f2008" }
!
! PR fortran/32599
! Verifies that character string arguments to a bind(c) procedure have length
! 1, or no len is specified.
! Verifies that character string arguments to a bind(c) procedure have length
! 1, or no len is specified. Note that the C interop extensions in F2018 allow
! string arguments of length greater than one to be passed to a C descriptor.
!
module pr32599
interface
subroutine destroy(path) BIND(C) ! { dg-error "must be length 1" }
use iso_c_binding
implicit none
character(len=*,kind=c_char), intent(IN) :: path
character(len=*,kind=c_char), intent(IN) :: path
end subroutine destroy
subroutine create(path) BIND(C) ! { dg-error "must be length 1" }
use iso_c_binding
implicit none
character(len=5,kind=c_char), intent(IN) :: path
character(len=5,kind=c_char), intent(IN) :: path
end subroutine create
! This should be valid.
subroutine create1(path) BIND(C)
use iso_c_binding
implicit none
character(len=1,kind=c_char), intent(IN) :: path
character(len=1,kind=c_char), intent(IN) :: path
end subroutine create1
! This should be valid.

16
libgfortran/ChangeLog
View file

@ -1,3 +1,17 @@
2019-02-23 Paul Thomas <pault@gcc.gnu.org>
PR fortran/89385
PR fortran/89366
* runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc) : In the
interchange between character and derived, the character type
was being set incorrectly.
(gfc_desc_to_cfi_desc) : Eliminate the interchange of types in
this function. Do not add the kind and length information to
the type field of structures. Lbounds were incorrectly being
set to zero for allocatable and pointer descriptors. Should
have been non-pointer, non-allocatables that received this
treatment.
2019-01-30 Uroš Bizjak <ubizjak@gmail.com>
PR libfortran/88678
@ -47,7 +61,7 @@
PR libfortran/88776
* io/open.c (newunit): Free format buffer if the unit specified is for
stdin, stdout, or stderr.
stdin, stdout, or stderr.
2019-01-12 Jerry DeLisle <jvdelisle@gcc.gnu.org>

11
libgfortran/runtime/ISO_Fortran_binding.c
View file

@ -59,7 +59,7 @@ cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
if (GFC_DESCRIPTOR_TYPE (d) == BT_CHARACTER)
GFC_DESCRIPTOR_TYPE (d) = BT_DERIVED;
else if (GFC_DESCRIPTOR_TYPE (d) == BT_DERIVED)
GFC_DESCRIPTOR_TYPE (d) = BT_DERIVED;
GFC_DESCRIPTOR_TYPE (d) = BT_CHARACTER;
d->dtype.attribute = (signed short)s->attribute;
@ -105,19 +105,20 @@ gfc_desc_to_cfi_desc (CFI_cdesc_t **d_ptr, const gfc_array_void *s)
d->attribute = (CFI_attribute_t)s->dtype.attribute;
if (GFC_DESCRIPTOR_TYPE (s) == BT_CHARACTER)
d->type = CFI_type_struct;
else if (GFC_DESCRIPTOR_TYPE (s) == BT_DERIVED)
d->type = CFI_type_Character;
else if (GFC_DESCRIPTOR_TYPE (s) == BT_DERIVED)
d->type = CFI_type_struct;
else
d->type = (CFI_type_t)GFC_DESCRIPTOR_TYPE (s);
d->type = (CFI_type_t)(d->type
if (GFC_DESCRIPTOR_TYPE (s) != BT_DERIVED)
d->type = (CFI_type_t)(d->type
+ ((CFI_type_t)d->elem_len << CFI_type_kind_shift));
/* Full pointer or allocatable arrays have zero lower_bound. */
for (n = 0; n < GFC_DESCRIPTOR_RANK (s); n++)
{
if (d->attribute == CFI_attribute_other)
if (d->attribute != CFI_attribute_other)
d->dim[n].lower_bound = (CFI_index_t)GFC_DESCRIPTOR_LBOUND(s, n);
else
d->dim[n].lower_bound = 0;