[fortran] PR89841 - improper descriptor information passed to C

Message ID CAGkQGi+MvHw9Ke73AYEG52fo6_XLNMXiC+xDhABnJ4gQ5PwYcA@mail.gmail.com
State New
Headers show
Series
  • [fortran] PR89841 - improper descriptor information passed to C
Related show

Commit Message

Paul Richard Thomas March 27, 2019, 6:50 p.m.
This corrects a screw-up on my part. The attribute field of the CFI
descriptor must be set by the formal argument in the interface and not
the actual argument.

Most of the work was in correcting

Bootstrapped and regtested on FC29/x86_64 - OK for trunk?

Cheers

Paul

2019-03-27  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.

2019-03-27  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.

Comments

Steve Kargl March 27, 2019, 6:54 p.m. | #1
On Wed, Mar 27, 2019 at 06:50:41PM +0000, Paul Richard Thomas wrote:
> This corrects a screw-up on my part. The attribute field of the CFI

> descriptor must be set by the formal argument in the interface and not

> the actual argument.

> 

> Most of the work was in correcting

> 

> Bootstrapped and regtested on FC29/x86_64 - OK for trunk?

> 


OK.

-- 
Steve
Paul Richard Thomas March 30, 2019, 3:43 p.m. | #2
Hi Steve,

Sorry about the delay. Daytime stuff caught up with me.

While I was about it, I committed the fix for PR89841 with the fix for
PR89842. The latter is even safer than the former.

Committed as revision 270037.

Thanks

Paul

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.

On Wed, 27 Mar 2019 at 18:55, Steve Kargl
<sgk@troutmask.apl.washington.edu> wrote:
>

> On Wed, Mar 27, 2019 at 06:50:41PM +0000, Paul Richard Thomas wrote:

> > This corrects a screw-up on my part. The attribute field of the CFI

> > descriptor must be set by the formal argument in the interface and not

> > the actual argument.

> >

> > Most of the work was in correcting

> >

> > Bootstrapped and regtested on FC29/x86_64 - OK for trunk?

> >

>

> OK.

>

> --

> Steve




-- 
"If you can't explain it simply, you don't understand it well enough"
- Albert Einstein

Patch

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 269962)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_gfc_desc_to_cfi_desc (gfc_se *p
*** 4998,5006 ****
    attribute = 2;
    if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
      {
!       if (attr.pointer)
  	attribute = 0;
!       else if (attr.allocatable)
  	attribute = 1;
      }
  
--- 4998,5006 ----
    attribute = 2;
    if (!e->rank || gfc_get_full_arrayspec_from_expr (e))
      {
!       if (fsym->attr.pointer)
  	attribute = 0;
!       else if (fsym->attr.allocatable)
  	attribute = 1;
      }
  
Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90	(revision 269961)
--- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_1.f90	(working copy)
***************
*** 25,37 ****
      FUNCTION c_deallocate(a) BIND(C, NAME="deallocate_c") RESULT(err)
        USE, INTRINSIC :: ISO_C_BINDING
        INTEGER(C_INT) :: err
!       type(*), DIMENSION(..) :: 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_INTPTR_T), DIMENSION(15) :: lower, upper
      END FUNCTION c_allocate
  
--- 25,37 ----
      FUNCTION c_deallocate(a) BIND(C, NAME="deallocate_c") RESULT(err)
        USE, INTRINSIC :: ISO_C_BINDING
        INTEGER(C_INT) :: err
!       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
!       INTEGER(C_INT), DIMENSION(..), allocatable :: a
        integer(C_INTPTR_T), DIMENSION(15) :: lower, upper
      END FUNCTION c_allocate
  
***************
*** 67,73 ****
        USE, INTRINSIC :: ISO_C_BINDING
        INTEGER(C_INT) :: err
        INTEGER(C_INT), dimension(2) :: lbounds
!       type(*), DIMENSION(..) :: a
      END FUNCTION c_setpointer
  
      FUNCTION c_assumed_size(a) BIND(C, NAME="assumed_size_c") RESULT(err)
--- 67,73 ----
        USE, INTRINSIC :: ISO_C_BINDING
        INTEGER(C_INT) :: err
        INTEGER(C_INT), dimension(2) :: lbounds
!       INTEGER(C_INT), DIMENSION(..), pointer :: a
      END FUNCTION c_setpointer
  
      FUNCTION c_assumed_size(a) BIND(C, NAME="assumed_size_c") RESULT(err)
Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.c
===================================================================
*** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.c	(nonexistent)
--- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.c	(working copy)
***************
*** 0 ****
--- 1,102 ----
+ /* 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;
+ }
+ 
+ 
Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.f90
===================================================================
*** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.f90	(nonexistent)
--- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_7.f90	(working copy)
***************
*** 0 ****
--- 1,42 ----
+ ! { 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
+