diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 054936b6886..3b5028cd0c2 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2019-02-23 Paul Thomas + + 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 Jakub Jelinek diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 9d6aa7d25c6..3c8c5ffaaaa 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -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; } } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 223fd14cd7b..cff3d7c2930 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4751104d106..0d1cdecd6df 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,17 @@ +2019-02-23 Paul Thomas + + 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 PR c++/89390 diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 index 4a11e22884f..e12b3a06e41 100644 --- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_5.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_5.c new file mode 100644 index 00000000000..116f548ad99 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_5.c @@ -0,0 +1,83 @@ +/* Test fix for PR89385. */ + +/* Contributed by Reinhold Bader */ + +#include +#include +#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; + +} + diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_5.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_5.f90 new file mode 100644 index 00000000000..97c2c5202bb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_5.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-additional-sources ISO_Fortran_binding_5.c } +! +! Test fix of PR89385. +! +! Contributed by Reinhold Bader +! +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 diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_6.c b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_6.c new file mode 100644 index 00000000000..704b27cb28a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_6.c @@ -0,0 +1,23 @@ +/* Test fix for PR89366. */ + +/* Contributed by Reinhold Bader */ + +#include +#include +#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); + } + +} diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_6.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_6.f90 new file mode 100644 index 00000000000..a5b34be62d8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_6.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! { dg-additional-sources ISO_Fortran_binding_6.c } +! +! Test fix of PR89366. +! +! Contributed by Reinhold Bader +! +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 diff --git a/gcc/testsuite/gfortran.dg/pr32599.f03 b/gcc/testsuite/gfortran.dg/pr32599.f03 index fa8aa68f928..297b75a7444 100644 --- a/gcc/testsuite/gfortran.dg/pr32599.f03 +++ b/gcc/testsuite/gfortran.dg/pr32599.f03 @@ -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. diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 9c72dfe9f58..d0a3962ba29 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,17 @@ +2019-02-23 Paul Thomas + + 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 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 diff --git a/libgfortran/runtime/ISO_Fortran_binding.c b/libgfortran/runtime/ISO_Fortran_binding.c index 4161a748b91..6b7b10fb836 100644 --- a/libgfortran/runtime/ISO_Fortran_binding.c +++ b/libgfortran/runtime/ISO_Fortran_binding.c @@ -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;