The attached patch is verging on the obvious. Thanks to Tobias for
spotting Vipul's messages on the J3 list.
Regtests on FC30/x86_64 - OK for trunk and 9-branch?
Paul
2019-11-03 Paul Thomas <[email protected]>
PR fortran/92123
*decl.c (gfc_verify_c_interop_param): Remove error asserting
that pointer or allocatable variables in a bind C procedure are
not supported. Delete some trailing spaces.
* trans-stmt.c (trans_associate_var): Correct the attempt to
treat scalar pointer or allocatable temporaries as if they are
array descriptors.
2019-11-03 Paul Thomas <[email protected]>
PR fortran/92123
* gfortran.dg/bind_c_procs_3.f90 : New test.
* gfortran.dg/ISO_Fortran_binding_15.c : New test.
* gfortran.dg/ISO_Fortran_binding_15.f90 : Additional source.
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 277531)
--- gcc/fortran/decl.c (working copy)
*************** gfc_verify_c_interop_param (gfc_symbol *
*** 1560,1574 ****
sym->ns->proc_name->name))
retval = false;
- if ((sym->attr.allocatable || sym->attr.pointer) && !sym->as)
- {
- gfc_error ("Scalar variable %qs at %L with POINTER or "
- "ALLOCATABLE in procedure %qs with BIND(C) is not yet"
- " supported", sym->name, &(sym->declared_at),
- sym->ns->proc_name->name);
- retval = false;
- }
-
if (sym->attr.optional == 1 && sym->attr.value)
{
gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
--- 1560,1565 ----
*************** gfc_match_entry (void)
*** 7547,7553 ****
entry->attr.is_bind_c = 0;
loc = entry->old_symbol != NULL
! ? entry->old_symbol->declared_at : gfc_current_locus;
gfc_error_now ("BIND(C) attribute at %L can only be used for "
"variables or common blocks", &loc);
}
--- 7538,7544 ----
entry->attr.is_bind_c = 0;
loc = entry->old_symbol != NULL
! ? entry->old_symbol->declared_at : gfc_current_locus;
gfc_error_now ("BIND(C) attribute at %L can only be used for "
"variables or common blocks", &loc);
}
*************** gfc_match_derived_decl (void)
*** 10288,10294 ****
}
/* In free source form, need to check for TYPE XXX as oppose to TYPEXXX.
! But, we need to simply return for TYPE(. */
if (m == MATCH_NO && gfc_current_form == FORM_FREE)
{
char c = gfc_peek_ascii_char ();
--- 10279,10285 ----
}
/* In free source form, need to check for TYPE XXX as oppose to TYPEXXX.
! But, we need to simply return for TYPE(. */
if (m == MATCH_NO && gfc_current_form == FORM_FREE)
{
char c = gfc_peek_ascii_char ();
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 277531)
--- gcc/fortran/trans-stmt.c (working copy)
*************** trans_associate_var (gfc_symbol *sym, gf
*** 1841,1850 ****
if (rank > 0)
copy_descriptor (&se.post, se.expr, desc, rank);
else
! {
! tmp = gfc_conv_descriptor_data_get (desc);
! gfc_conv_descriptor_data_set (&se.post, se.expr, tmp);
! }
/* The dynamic type could have changed too. */
if (sym->ts.type == BT_CLASS)
--- 1841,1847 ----
if (rank > 0)
copy_descriptor (&se.post, se.expr, desc, rank);
else
! gfc_conv_descriptor_data_set (&se.post, se.expr, desc);
/* The dynamic type could have changed too. */
if (sym->ts.type == BT_CLASS)
Index: gcc/testsuite/gfortran.dg/bind_c_procs_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/bind_c_procs_3.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/bind_c_procs_3.f90 (working copy)
***************
*** 0 ****
--- 1,25 ----
+ ! { dg-do run }
+ !
+ ! Test the fix for PR92123, in which 'dat' caused an error with the message
+ ! "Scalar variable 'dat' at ?? with POINTER or ALLOCATABLE in procedure Fsub
+ ! with BIND(C) is not yet supported."
+ !
+ ! Contributed by Vipul Parekh <[email protected]>
+ !
+ module m
+ use, intrinsic :: iso_c_binding, only : c_int
+ contains
+ subroutine Fsub( dat ) bind(C, name="Fsub")
+ !.. Argument list
+ integer(c_int), allocatable, intent(out) :: dat
+ dat = 42
+ return
+ end subroutine
+ end module m
+
+ use, intrinsic :: iso_c_binding, only : c_int
+ use m, only : Fsub
+ integer(c_int), allocatable :: x
+ call Fsub( x )
+ if (x .ne. 42) stop 1
+ end
Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.c
===================================================================
*** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.c (nonexistent)
--- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.c (working copy)
***************
*** 0 ****
--- 1,41 ----
+ /* Test the fix for PR92123. */
+
+ /* Contributed by Vipul Parekh <[email protected]> */
+
+ #include <stdlib.h>
+ #include <stdio.h>
+ #include "../../../libgfortran/ISO_Fortran_binding.h"
+
+ // Prototype for Fortran functions
+ extern void Fsub(CFI_cdesc_t *);
+
+ int main()
+ {
+ CFI_CDESC_T(0) dat;
+ int irc = 0;
+
+ irc = CFI_establish((CFI_cdesc_t *)&dat, NULL,
+ CFI_attribute_allocatable,
+ CFI_type_int, 0, (CFI_rank_t)0, NULL);
+ if (irc != CFI_SUCCESS)
+ {
+ printf("CFI_establish failed: irc = %d.\n", irc);
+ return EXIT_FAILURE;
+ }
+
+ Fsub((CFI_cdesc_t *)&dat);
+ if (*(int *)dat.base_addr != 42)
+ {
+ printf("Fsub returned = %d.\n", *(int *)dat.base_addr);
+ return EXIT_FAILURE;
+ }
+
+ irc = CFI_deallocate((CFI_cdesc_t *)&dat);
+ if (irc != CFI_SUCCESS)
+ {
+ printf("CFI_deallocate for dat failed: irc = %d.\n", irc);
+ return EXIT_FAILURE;
+ }
+
+ return EXIT_SUCCESS;
+ }
Index: gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.f90
===================================================================
*** gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.f90 (nonexistent)
--- gcc/testsuite/gfortran.dg/ISO_Fortran_binding_15.f90 (working copy)
***************
*** 0 ****
--- 1,20 ----
+ ! { dg-do run { target c99_runtime } }
+ ! { dg-additional-sources ISO_Fortran_binding_15.c }
+ !
+ ! Test the fix for PR921233. The additional source is the main program.
+ !
+ ! Contributed by Vipul Parekh <[email protected]>
+ !
+ module m
+ use, intrinsic :: iso_c_binding, only : c_int
+ contains
+ subroutine Fsub( dat ) bind(C, name="Fsub")
+ integer(c_int), allocatable, intent(out) :: dat(..)
+ select rank (dat)
+ rank (0)
+ allocate( dat )
+ dat = 42
+ end select
+ return
+ end subroutine
+ end module m
