OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/32600 ([ISO Bind C] C_F_POINTER w/o SHAPE should not be a library function) 

2007-07-23  Christopher D. Rickett  <crickett@lanl.gov>
	    Tobias Burnus  <burnus@net-b.de>

	PR fortran/32600
	* trans-expr.c (gfc_conv_function_call): Handle c_funloc.
	* trans-types.c: Add pfunc_type_node.
	(gfc_init_types,gfc_typenode_for_spec): Use it.
	* resolve.c (gfc_iso_c_func_interface): Fix whitespace and
	improve error message.

2007-07-23  Christopher D. Rickett  <crickett@lanl.gov>

	PR fortran/32600
	* intrinsics/iso_c_binding.c (c_funloc): Remove.
	* intrinsics/iso_c_binding.h: Remove c_funloc.
	* gfortran.map: Ditto.

2007-07-23  Christopher D. Rickett  <crickett@lanl.gov>

	PR fortran/32600
	* gfortran.dg/c_funloc_tests_5.f03: New.
	* gfortran.dg/c_funloc_tests_5.f04: New.
	* gfortran.dg/c_funloc_tests_4_driver.c: New.


Co-Authored-By: Tobias Burnus <burnus@net-b.de>

From-SVN: r126835
This commit is contained in:
Christopher D. Rickett 2007-07-23 06:03:33 +00:00 committed by Tobias Burnus
parent db75c37a3a
commit 089db47df6
12 changed files with 191 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
gcc/fortran/ChangeLog
View File

@ -1,3 +1,13 @@
2007-07-23 Christopher D. Rickett <crickett@lanl.gov>
Tobias Burnus <burnus@net-b.de>
PR fortran/32600
* trans-expr.c (gfc_conv_function_call): Handle c_funloc.
* trans-types.c: Add pfunc_type_node.
(gfc_init_types,gfc_typenode_for_spec): Use it.
* resolve.c (gfc_iso_c_func_interface): Fix whitespace and
improve error message.
2007-07-22 Daniel Franke <franke.daniel@gmail.com>
PR fortran/32710

16
gcc/fortran/resolve.c
View File

@ -1904,14 +1904,14 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
&(args->expr->where));
retval = FAILURE;
}
else if (args->expr->symtree->n.sym->attr.is_c_interop != 1)
{
gfc_error_now ("Parameter '%s' to '%s' at %L must be C "
"interoperable",
args->expr->symtree->n.sym->name, sym->name,
&(args->expr->where));
retval = FAILURE;
}
else if (args->expr->symtree->n.sym->attr.is_bind_c != 1)
{
gfc_error_now ("Parameter '%s' to '%s' at %L must be "
"BIND(C)",
args->expr->symtree->n.sym->name, sym->name,
&(args->expr->where));
retval = FAILURE;
}
}
/* for c_loc/c_funloc, the new symbol is the same as the old one */

49
gcc/fortran/trans-expr.c
View File

@ -2060,31 +2060,40 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
var = NULL_TREE;
len = NULL_TREE;
if (sym->from_intmod == INTMOD_ISO_C_BINDING
&& sym->intmod_sym_id == ISOCBINDING_LOC)
if (sym->from_intmod == INTMOD_ISO_C_BINDING)
{
if (arg->expr->rank == 0)
if (sym->intmod_sym_id == ISOCBINDING_LOC)
{
gfc_conv_expr_reference (se, arg->expr);
}
else
{
int f;
/* This is really the actual arg because no formal arglist is
created for C_LOC. */
fsym = arg->expr->symtree->n.sym;
if (arg->expr->rank == 0)
gfc_conv_expr_reference (se, arg->expr);
else
{
int f;
/* This is really the actual arg because no formal arglist is
created for C_LOC. */
fsym = arg->expr->symtree->n.sym;
/* We should want it to do g77 calling convention. */
f = (fsym != NULL)
&& !(fsym->attr.pointer || fsym->attr.allocatable)
&& fsym->as->type != AS_ASSUMED_SHAPE;
f = f || !sym->attr.always_explicit;
/* We should want it to do g77 calling convention. */
f = (fsym != NULL)
&& !(fsym->attr.pointer || fsym->attr.allocatable)
&& fsym->as->type != AS_ASSUMED_SHAPE;
f = f || !sym->attr.always_explicit;
argss = gfc_walk_expr (arg->expr);
gfc_conv_array_parameter (se, arg->expr, argss, f);
}
argss = gfc_walk_expr (arg->expr);
gfc_conv_array_parameter (se, arg->expr, argss, f);
}
return 0;
return 0;
}
else if (sym->intmod_sym_id == ISOCBINDING_FUNLOC)
{
arg->expr->ts.type = sym->ts.derived->ts.type;
arg->expr->ts.f90_type = sym->ts.derived->ts.f90_type;
arg->expr->ts.kind = sym->ts.derived->ts.kind;
gfc_conv_expr_reference (se, arg->expr);
return 0;
}
}
if (se->ss != NULL)

30
gcc/fortran/trans-types.c
View File

@ -60,6 +60,7 @@ tree gfc_character1_type_node;
tree pvoid_type_node;
tree ppvoid_type_node;
tree pchar_type_node;
tree pfunc_type_node;
tree gfc_charlen_type_node;
@ -733,6 +734,8 @@ gfc_init_types (void)
pvoid_type_node = build_pointer_type (void_type_node);
ppvoid_type_node = build_pointer_type (pvoid_type_node);
pchar_type_node = build_pointer_type (gfc_character1_type_node);
pfunc_type_node
= build_pointer_type (build_function_type (void_type_node, NULL_TREE));
gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
/* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
@ -842,7 +845,13 @@ gfc_typenode_for_spec (gfc_typespec * spec)
has been resolved. This is done so we can convert C_PTR and
C_FUNPTR to simple variables that get translated to (void *). */
if (spec->f90_type == BT_VOID)
basetype = ptr_type_node;
{
if (spec->derived
&& spec->derived->intmod_sym_id == ISOCBINDING_PTR)
basetype = ptr_type_node;
else
basetype = pfunc_type_node;
}
else
basetype = gfc_get_int_type (spec->kind);
break;
@ -878,9 +887,17 @@ gfc_typenode_for_spec (gfc_typespec * spec)
}
break;
case BT_VOID:
/* This is for the second arg to c_f_pointer and c_f_procpointer
of the iso_c_binding module, to accept any ptr type. */
basetype = ptr_type_node;
/* This is for the second arg to c_f_pointer and c_f_procpointer
of the iso_c_binding module, to accept any ptr type. */
basetype = ptr_type_node;
if (spec->f90_type == BT_VOID)
{
if (spec->derived
&& spec->derived->intmod_sym_id == ISOCBINDING_PTR)
basetype = ptr_type_node;
else
basetype = pfunc_type_node;
}
break;
default:
gcc_unreachable ();
@ -1653,7 +1670,10 @@ gfc_get_derived_type (gfc_symbol * derived)
/* See if it's one of the iso_c_binding derived types. */
if (derived->attr.is_iso_c == 1)
{
derived->backend_decl = ptr_type_node;
if (derived->intmod_sym_id == ISOCBINDING_PTR)
derived->backend_decl = ptr_type_node;
else
derived->backend_decl = pfunc_type_node;
derived->ts.kind = gfc_index_integer_kind;
derived->ts.type = BT_INTEGER;
/* Set the f90_type to BT_VOID as a way to recognize something of type

7
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,10 @@
2007-07-23 Christopher D. Rickett <crickett@lanl.gov>
PR fortran/32600
* gfortran.dg/c_funloc_tests_5.f03: New.
* gfortran.dg/c_funloc_tests_5.f04: New.
* gfortran.dg/c_funloc_tests_4_driver.c: New.
2007-07-22 Nathan Sidwell <nathan@codesourcery.com>
PR c++/32839

40
gcc/testsuite/gfortran.dg/c_funloc_tests_4.f03 Normal file
View File

@ -0,0 +1,40 @@
! { dg-do run }
! { dg-additional-sources c_funloc_tests_4_driver.c }
! Test that the inlined c_funloc works.
module c_funloc_tests_4
use, intrinsic :: iso_c_binding, only: c_funloc, c_funptr
interface
subroutine c_sub0(fsub_ptr) bind(c)
use, intrinsic :: iso_c_binding, only: c_funptr
type(c_funptr), value :: fsub_ptr
end subroutine c_sub0
subroutine c_sub1(ffunc_ptr) bind(c)
use, intrinsic :: iso_c_binding, only: c_funptr
type(c_funptr), value :: ffunc_ptr
end subroutine c_sub1
end interface
contains
subroutine sub0() bind(c)
type(c_funptr) :: my_c_funptr
my_c_funptr = c_funloc(sub1)
call c_sub0(my_c_funptr)
my_c_funptr = c_funloc(func0)
call c_sub1(my_c_funptr)
end subroutine sub0
subroutine sub1() bind(c)
print *, 'hello from sub1'
end subroutine sub1
function func0(desired_retval) bind(c)
use, intrinsic :: iso_c_binding, only: c_int
integer(c_int), value :: desired_retval
integer(c_int) :: func0
print *, 'hello from func0'
func0 = desired_retval
end function func0
end module c_funloc_tests_4
! { dg-final { cleanup-modules "c_funloc_tests_4" } }

39
gcc/testsuite/gfortran.dg/c_funloc_tests_4_driver.c Normal file
View File

@ -0,0 +1,39 @@
#include <stdio.h>
void sub0(void);
void c_sub0(void (*sub)(void));
void c_sub1(int (*func)(int));
extern void abort(void);
int main(int argc, char **argv)
{
printf("hello from C main\n");
sub0();
return 0;
}
void c_sub0(void (*sub)(void))
{
printf("hello from c_sub0\n");
sub();
return;
}
void c_sub1(int (*func)(int))
{
int retval;
printf("hello from c_sub1\n");
retval = func(10);
if(retval != 10)
{
fprintf(stderr, "Fortran function did not return expected value!\n");
abort();
}
return;
}

26
gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 Normal file
View File

@ -0,0 +1,26 @@
! { dg-do compile }
! Test that the arg checking for c_funloc verifies the procedures are
! C interoperable.
module c_funloc_tests_5
use, intrinsic :: iso_c_binding, only: c_funloc, c_funptr
contains
subroutine sub0() bind(c)
type(c_funptr) :: my_c_funptr
my_c_funptr = c_funloc(sub1) ! { dg-error "must be BIND.C." }
my_c_funptr = c_funloc(func0) ! { dg-error "must be BIND.C." }
end subroutine sub0
subroutine sub1()
end subroutine sub1
function func0(desired_retval)
use, intrinsic :: iso_c_binding, only: c_int
integer(c_int), value :: desired_retval
integer(c_int) :: func0
func0 = desired_retval
end function func0
end module c_funloc_tests_5

7
libgfortran/ChangeLog
View File

@ -1,3 +1,10 @@
2007-07-23 Christopher D. Rickett <crickett@lanl.gov>
PR fortran/32600
* intrinsics/iso_c_binding.c (c_funloc): Remove.
* intrinsics/iso_c_binding.h: Remove c_funloc.
* gfortran.map: Ditto.
2007-07-22 Jerry DeLisle <jvdelisle@gcc.gnu.org>
* io/read.c (convert_real): Generate error only on EINVAL.

1
libgfortran/gfortran.map
View File

@ -1027,7 +1027,6 @@ GFORTRAN_1.0 {
__iso_c_binding_c_f_pointer_l8;
__iso_c_binding_c_f_pointer_u0;
__iso_c_binding_c_f_procpointer;
__iso_c_binding_c_funloc;
local:
*;
};

19
libgfortran/intrinsics/iso_c_binding.c
View File

@ -232,22 +232,3 @@ ISO_C_BINDING_PREFIX (c_associated_2) (void *c_ptr_in_1, void *c_ptr_in_2)
else
return 1;
}
/* Return the C address of the given Fortran procedure. This
routine is expected to return a derived type of type C_FUNPTR,
which represents the C address of the given Fortran object. */
void *
ISO_C_BINDING_PREFIX (c_funloc) (void *f90_obj)
{
if (f90_obj == NULL)
{
runtime_error ("C_LOC: Attempt to get C address for Fortran object"
" that has not been allocated or associated");
abort ();
}
/* The "C" address should be the address of the object in Fortran. */
return f90_obj;
}

2
libgfortran/intrinsics/iso_c_binding.h
View File

@ -64,6 +64,4 @@ void ISO_C_BINDING_PREFIX(c_f_pointer_u0) (void *, gfc_array_void *,
void ISO_C_BINDING_PREFIX(c_f_pointer_d0) (void *, gfc_array_void *,
const array_t *);
void *ISO_C_BINDING_PREFIX(c_funloc) (void *);
#endif