2019-03-30 Paul Thomas <pault@gcc.gnu.org>
PR fortran/89841
* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Use the formal
argument attributes rather than those of the actual argument.
PR fortran/89842
* trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Call
'set_dtype_for_unallocated' for any type of arrayspec.
2019-03-30 Paul Thomas <pault@gcc.gnu.org>
PR fortran/89841
* gfortran.dg/ISO_Fortran_binding_1.f90: Change the interfaces
for c_deallocate, c_allocate and c_assumed_size so that the
attributes of the array arguments are correct and are typed.
* gfortran.dg/ISO_Fortran_binding_7.f90: New test.
* gfortran.dg/ISO_Fortran_binding_7.c: Additional source.
PR fortran/89842
* gfortran.dg/ISO_Fortran_binding_8.f90: New test.
* gfortran.dg/ISO_Fortran_binding_8.c: Additional source.
From-SVN: r270037
+2019-03-30 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/89841
+ * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Use the formal
+ argument attributes rather than those of the actual argument.
+
+ PR fortran/89842
+ * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Call
+ 'set_dtype_for_unallocated' for any type of arrayspec.
+
2019-03-27 Janus Weil <janus@gcc.gnu.org>
PR fortran/85537
attribute = 2;
if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
{
- if (attr.pointer)
+ if (fsym->attr.pointer)
attribute = 0;
- else if (attr.allocatable)
+ else if (fsym->attr.allocatable)
attribute = 1;
}
need their dtype setting if they are argument associated with
assumed rank dummies. */
if (fsym && fsym->as
- && fsym->as->type == AS_ASSUMED_RANK
&& (gfc_expr_attr (e).pointer
|| gfc_expr_attr (e).allocatable))
set_dtype_for_unallocated (parmse, e);
+2019-03-30 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/89841
+ * gfortran.dg/ISO_Fortran_binding_1.f90: Change the interfaces
+ for c_deallocate, c_allocate and c_assumed_size so that the
+ attributes of the array arguments are correct and are typed.
+ * gfortran.dg/ISO_Fortran_binding_7.f90: New test.
+ * gfortran.dg/ISO_Fortran_binding_7.c: Additional source.
+
+ PR fortran/89842
+ * gfortran.dg/ISO_Fortran_binding_8.f90: New test.
+ * gfortran.dg/ISO_Fortran_binding_8.c: Additional source.
+
2019-03-30 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/89866
FUNCTION c_deallocate(a) BIND(C, NAME="deallocate_c") RESULT(err)
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: err
- type(*), DIMENSION(..) :: a
+ INTEGER(C_INT), DIMENSION(..), allocatable :: a
END FUNCTION c_deallocate
FUNCTION c_allocate(a, lower, upper) BIND(C, NAME="allocate_c") RESULT(err)
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: err
- type(*), DIMENSION(..) :: a
+ INTEGER(C_INT), DIMENSION(..), allocatable :: a
integer(C_INTPTR_T), DIMENSION(15) :: lower, upper
END FUNCTION c_allocate
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: err
INTEGER(C_INT), dimension(2) :: lbounds
- type(*), DIMENSION(..) :: a
+ INTEGER(C_INT), DIMENSION(..), pointer :: a
END FUNCTION c_setpointer
FUNCTION c_assumed_size(a) BIND(C, NAME="assumed_size_c") RESULT(err)
--- /dev/null
+/* Test the fix for PR89841. */
+
+/* Contributed by Reinhold Bader <Bader@lrz.de> */
+
+#include "../../../libgfortran/ISO_Fortran_binding.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+
+typedef struct
+ {
+ int i;
+ float r[2];
+ } cstruct;
+
+
+int Psuba(CFI_cdesc_t *this, CFI_cdesc_t *that, int Dcase) {
+ int status = 0;
+ cstruct *cu;
+ float *ct;
+ CFI_dim_t *dim;
+ if (this->elem_len != sizeof(float))
+ {
+ printf("FAIL: Dcase %i - this->elem_len %i\n",Dcase, (int) this->elem_len);
+ status++;
+ }
+ if (this->type != CFI_type_float)
+ {
+ printf("FAIL: Dcase %i - this->type\n", Dcase);
+ status++;
+ }
+ if (this->rank != 2)
+ {
+ printf("FAIL: Dcase %i - this->rank %i\n",Dcase,this->rank);
+ status++;
+ }
+ if (this->attribute != CFI_attribute_other)
+ {
+ printf("FAIL: Dcase %i - this->attribute\n", Dcase);
+ status++;
+ }
+
+ dim = this->dim;
+ if (dim[0].lower_bound != 0 || dim[0].extent != 3)
+ {
+ printf("FAIL: Dcase %i - dim[0] %i %i %i\n",Dcase, (int) dim[0].lower_bound,
+ (int)dim[0].extent,(int)dim[0].sm);
+ status++;
+ }
+ if (dim[1].lower_bound != 0 || dim[1].extent != 7)
+ {
+ printf("FAIL: Dcase %i - dim[1] %i %i %i\n",Dcase,(int) dim[1].lower_bound,
+ (int) dim[1].extent,(int) dim[1].sm);
+ status++;
+ }
+
+ if (that->elem_len != sizeof(cstruct))
+ {
+ printf("FAIL: Dcase %i - that->elem_len\n", Dcase);
+ status++;
+ }
+ if (that->type != CFI_type_struct)
+ {
+ printf("FAIL: Dcase %i - that->type\n",Dcase);
+ status++;
+ }
+ if (that->rank != 1)
+ {
+ printf("FAIL: Dcase %i - that->rank\n", Dcase);
+ status++;
+ }
+ if (that->attribute != CFI_attribute_other)
+ {
+ printf("FAIL: Dcase %i - that->attribute %i\n",Dcase,that->attribute);
+ status++;
+ }
+
+ dim = that->dim;
+ if (dim[0].lower_bound != 0 || dim[0].extent != 1)
+ {
+ printf("FAIL: Dcase %i - dim[0] %i %i\n",Dcase,(int)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: Dcase %i - value of that %i %f %f\n",Dcase,cu->i,cu->r[0],cu->r[1]);
+ status++;
+ }
+
+ ct = (float *) ((CFI_cdesc_t *) this)->base_addr;
+ if ( fabs(ct[5] + 2.0) > 1.0e-6)
+ {
+ printf("FAIL: Dcase %i - value of this %f\n",Dcase,ct[5]);
+ status++;
+ }
+
+ return status;
+}
+
+
--- /dev/null
+! { dg-do run { target c99_runtime } }
+! { dg-additional-sources ISO_Fortran_binding_7.c }
+!
+! Test the fix for PR89841.
+!
+! Contributed by Reinhold Bader <Bader@lrz.de>
+!
+program assumed_shape_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
+ function psub(this, that, case) bind(c, name='Psuba') result(status)
+ import :: c_float, c_int, cstruct
+ real(c_float) :: this(:,:)
+ type(cstruct) :: that(:)
+ integer(c_int), value :: case
+ integer(c_int) :: status
+ end function psub
+ end interface
+
+ real(c_float) :: t(3,7)
+ type(cstruct), pointer :: u(:)
+ type(cstruct), allocatable :: v(:)
+ integer(c_int) :: st
+
+ allocate(u(1), source=[cstruct( 4, [1.1,2.2] ) ])
+ allocate(v(1), source=[cstruct( 4, [1.1,2.2] ) ])
+ t = 0.0
+ t(3,2) = -2.0
+ st = psub(t, u, 1)
+ if (st .ne. 0) stop 1
+ st = psub(t, v, 2)
+ if (st .ne. 0) stop 2
+ deallocate (u)
+ deallocate (v)
+
+end program assumed_shape_01
+
--- /dev/null
+/* Test the fix for PR89841. */
+
+/* Contributed by Reinhold Bader <Bader@lrz.de> */
+
+#include "../../../libgfortran/ISO_Fortran_binding.h"
+#include <stdio.h>
+
+float Cxgl[] = { 1.1, 2.3, 5.1, 4.2 };
+
+void globalp(CFI_cdesc_t *this)
+{
+ int i, status;
+ float *pt;
+ CFI_index_t lb[] = { 3 };
+ CFI_index_t ub[] = { 6 };
+
+ if (this->base_addr == NULL)
+ {
+ status = CFI_allocate(this, lb, ub, 0);
+ }
+ else
+ {
+ printf("FAIL C: already allocated.\n");
+ return;
+ }
+
+ if (status != CFI_SUCCESS)
+ {
+ printf("FAIL C: status is %i\n",status);
+ }
+
+ pt = (float *) this->base_addr;
+ for (i=0; i<4; i++)
+ {
+ pt[i] = Cxgl[i];
+ }
+}
--- /dev/null
+! { dg-do run { target c99_runtime } }
+! { dg-additional-sources ISO_Fortran_binding_8.c }
+!
+! Test the fix for PR89842.
+!
+! Contributed by Reinhold Bader <Bader@lrz.de>
+!
+module mod_alloc_01
+ use, intrinsic :: iso_c_binding
+ implicit none
+
+ interface
+ subroutine globalp(this) bind(c)
+ import :: c_float
+ real(c_float), allocatable :: this(:)
+ end subroutine globalp
+ end interface
+end module mod_alloc_01
+
+program alloc_01
+ use mod_alloc_01
+ implicit none
+
+ real(c_float), allocatable :: myp(:)
+ integer :: status
+
+ status = 0
+ call globalp(myp)
+
+! write(*,*) 'globalp done'
+ if (.not. allocated(myp)) then
+ write(*,*) 'FAIL 1'
+ stop 1
+ end if
+ if (lbound(myp,1) /= 3 .or. size(myp,1) /= 4) then
+ write(*,*) 'FAIL 2: ', lbound(myp), size(myp,1)
+ status = status + 1
+ else
+! write(*,*) 'Now checking data', myp(3)
+ if (maxval(abs(myp - [1.1, 2.3, 5.1, 4.2])) > 1.0e-6) then
+ write(*,*) 'FAIL 3: ', myp
+ status = status + 1
+ end if
+ end if
+
+ if (status .ne. 0) then
+ stop status
+ end if
+end program alloc_01
+
projects / gcc.git / commitdiff