===================================================================
*************** gfc_verify_c_interop_param (gfc_symbol *
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 "
*************** gfc_match_entry (void)
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);
}
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)
}
/* 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 ();
}
/* 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 ();
===================================================================
*************** trans_associate_var (gfc_symbol *sym, gf
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)
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)
===================================================================
***************
+ ! { 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 <parekhvs@gmail.com>
+ !
+ 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
===================================================================
***************
+ /* Test the fix for PR92123. */
+
+ /* Contributed by Vipul Parekh <parekhvs@gmail.com> */
+
+ #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;
+ }
===================================================================
***************
+ ! { 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 <parekhvs@gmail.com>
+ !
+ 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