Skip to content

R
riscv-gcc-1
Commit 1eabf70a by Tobias Burnus Committed by Tobias Burnus
Options

re PR fortran/34133 (Bind(c,name="") should be rejected for dummies; F2008:… 

re PR fortran/34133 (Bind(c,name="") should be rejected for dummies; F2008: allow bind(c) for internal procs)

2007-11-20  Tobias Burnus  <burnus@net-b.de>

        PR fortran/34133
        * match.h: Add bool allow_binding_name to gfc_match_bind_c.
        * decl.c
        * (match_attr_spec,gfc_match_bind_c_stmt,gfc_match_entry):
        Adjust accordingly.
        (gfc_match_bind_c): Add allow_binding_name argument, reject
        binding name for dummy arguments.
        (gfc_match_suffix,gfc_match_subroutine): Make use of
        allow_binding_name.

2007-11-20  Tobias Burnus  <burnus@net-b.de>

        PR fortran/34133
        * gfortran.dg/bind_c_usage_9.f03: Fixes; add -std=f2003.
        * gfortran.dg/bind_c_usage_11.f03: New.
        * gfortran.dg/bind_c_usage_12.f03: New.

From-SVN: r130535
parent e6ef7325
Showing with 199 additions and 33 deletions
gcc/fortran/ChangeLog
2007-11-30 Tobias Burnus <burnus@net-b.de>
PR fortran/34133
* match.h: Add bool allow_binding_name to gfc_match_bind_c.
* decl.c (match_attr_spec,gfc_match_bind_c_stmt,gfc_match_entry):
Adjust accordingly.
(gfc_match_bind_c): Add allow_binding_name argument, reject
binding name for dummy arguments.
(gfc_match_suffix,gfc_match_subroutine): Make use of
allow_binding_name.
2007-11-30 Tobias Burnus <burnus@net-b.de>
PR fortran/34186
* symbol.c (generate_isocbinding_symbol): Set string length.
* dump-parse-tree.c (gfc_show_attr): Show BIND(C) attribute.
......
gcc/fortran/decl.c
......@@ -2720,7 +2720,7 @@ match_attr_spec (void)
case 'b':
/* Try and match the bind(c). */
m = gfc_match_bind_c (NULL);
m = gfc_match_bind_c (NULL, true);
if (m == MATCH_YES)
d = DECL_IS_BIND_C;
else if (m == MATCH_ERROR)
......@@ -3508,7 +3508,7 @@ gfc_match_bind_c_stmt (void)
curr_binding_label[0] = '\0';
/* Look for the bind(c). */
found_match = gfc_match_bind_c (NULL);
found_match = gfc_match_bind_c (NULL, true);
if (found_match == MATCH_YES)
{
......@@ -3870,6 +3870,7 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
match is_result; /* Found result clause. */
match found_match; /* Status of whether we've found a good match. */
int peek_char; /* Character we're going to peek at. */
bool allow_binding_name;
/* Initialize to having found nothing. */
found_match = MATCH_NO;
......@@ -3880,6 +3881,13 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
gfc_gobble_whitespace ();
peek_char = gfc_peek_char ();
/* C binding names are not allowed for internal procedures. */
if (gfc_current_state () == COMP_CONTAINS
&& sym->ns->proc_name->attr.flavor != FL_MODULE)
allow_binding_name = false;
else
allow_binding_name = true;
switch (peek_char)
{
case 'r':
......@@ -3888,7 +3896,7 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
if (is_result == MATCH_YES)
{
/* Now see if there is a bind(c) after it. */
is_bind_c = gfc_match_bind_c (sym);
is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
/* We've found the result clause and possibly bind(c). */
found_match = MATCH_YES;
}
......@@ -3898,7 +3906,7 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
break;
case 'b':
/* Look for bind(c) first. */
is_bind_c = gfc_match_bind_c (sym);
is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
if (is_bind_c == MATCH_YES)
{
/* Now see if a result clause followed it. */
......@@ -3919,13 +3927,15 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
if (is_bind_c == MATCH_YES)
{
/* Fortran 2008 draft allows BIND(C) for internal procedures. */
if (gfc_current_state () == COMP_CONTAINS
&& sym->ns->proc_name->attr.flavor != FL_MODULE)
{
gfc_error ("BIND(C) attribute at %L may not be specified for an "
"internal procedure", &gfc_current_locus);
return MATCH_ERROR;
}
&& sym->ns->proc_name->attr.flavor != FL_MODULE
&& gfc_notify_std (GFC_STD_GNU, "Extension: BIND(C) attribute at %L "
"may not be specified for an internal procedure",
&gfc_current_locus)
== FAILURE)
return MATCH_ERROR;
if (gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1)
== FAILURE)
return MATCH_ERROR;
......@@ -4453,7 +4463,9 @@ gfc_match_entry (void)
if (m != MATCH_YES)
return MATCH_ERROR;
is_bind_c = gfc_match_bind_c (entry);
/* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
never be an internal procedure. */
is_bind_c = gfc_match_bind_c (entry, true);
if (is_bind_c == MATCH_ERROR)
return MATCH_ERROR;
if (is_bind_c == MATCH_YES)
......@@ -4573,6 +4585,7 @@ gfc_match_subroutine (void)
match m;
match is_bind_c;
char peek_char;
bool allow_binding_name;
if (gfc_current_state () != COMP_NONE
&& gfc_current_state () != COMP_INTERFACE
......@@ -4616,11 +4629,18 @@ gfc_match_subroutine (void)
gfc_error_now ("BIND(C) attribute at %L can only be used for "
"variables or common blocks", &gfc_current_locus);
}
/* C binding names are not allowed for internal procedures. */
if (gfc_current_state () == COMP_CONTAINS
&& sym->ns->proc_name->attr.flavor != FL_MODULE)
allow_binding_name = false;
else
allow_binding_name = true;
/* Here, we are just checking if it has the bind(c) attribute, and if
so, then we need to make sure it's all correct. If it doesn't,
we still need to continue matching the rest of the subroutine line. */
is_bind_c = gfc_match_bind_c (sym);
is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
if (is_bind_c == MATCH_ERROR)
{
/* There was an attempt at the bind(c), but it was wrong. An
......@@ -4631,13 +4651,15 @@ gfc_match_subroutine (void)
if (is_bind_c == MATCH_YES)
{
/* The following is allowed in the Fortran 2008 draft. */
if (gfc_current_state () == COMP_CONTAINS
&& sym->ns->proc_name->attr.flavor != FL_MODULE)
{
gfc_error ("BIND(C) attribute at %L may not be specified for an "
"internal procedure", &gfc_current_locus);
return MATCH_ERROR;
}
&& sym->ns->proc_name->attr.flavor != FL_MODULE
&& gfc_notify_std (GFC_STD_GNU, "Extension: BIND(C) attribute at "
"%L may not be specified for an internal procedure",
&gfc_current_locus)
== FAILURE)
return MATCH_ERROR;
if (peek_char != '(')
{
gfc_error ("Missing required parentheses before BIND(C) at %C");
......@@ -4669,10 +4691,11 @@ gfc_match_subroutine (void)
MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
or MATCH_YES if the specifier was correct and the binding label and
bind(c) fields were set correctly for the given symbol or the
current_ts. */
current_ts. If allow_binding_name is false, no binding name may be
given. */
match
gfc_match_bind_c (gfc_symbol *sym)
gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
{
/* binding label, if exists */
char binding_label[GFC_MAX_SYMBOL_LEN + 1];
......@@ -4752,6 +4775,20 @@ gfc_match_bind_c (gfc_symbol *sym)
return MATCH_ERROR;
}
if (has_name_equals && !allow_binding_name)
{
gfc_error ("No binding name is allowed in BIND(C) at %C");
return MATCH_ERROR;
}
if (has_name_equals && sym != NULL && sym->attr.dummy)
{
gfc_error ("For dummy procedure %s, no binding name is "
"allowed in BIND(C) at %C", sym->name);
return MATCH_ERROR;
}
/* Save the binding label to the symbol. If sym is null, we're
probably matching the typespec attributes of a declaration and
haven't gotten the name yet, and therefore, no symbol yet. */
......@@ -4764,16 +4801,12 @@ gfc_match_bind_c (gfc_symbol *sym)
else
strcpy (curr_binding_label, binding_label);
}
else
else if (allow_binding_name)
{
/* No binding label, but if symbol isn't null, we
can set the label for it here. */
/* TODO: If the name= was given and no binding label (name=""), we simply
will let fortran mangle the symbol name as it usually would.
However, this could still let C call it if the user looked up the
symbol in the object file. Should the name set during mangling in
trans-decl.c be marked with characters that are invalid for C to
prevent this? */
can set the label for it here.
If name="" or allow_binding_name is false, no C binding name is
created. */
if (sym != NULL && sym->name != NULL && has_name_equals == 0)
strncpy (sym->binding_label, sym->name, strlen (sym->name) + 1);
}
......
gcc/fortran/match.h
......@@ -175,7 +175,7 @@ try set_verify_bind_c_com_block (gfc_common_head *, int);
try get_bind_c_idents (void);
match gfc_match_bind_c_stmt (void);
match gfc_match_suffix (gfc_symbol *, gfc_symbol **);
match gfc_match_bind_c (gfc_symbol *);
match gfc_match_bind_c (gfc_symbol *, bool);
match gfc_get_type_attr_spec (symbol_attribute *);
/* primary.c. */
......
gcc/testsuite/ChangeLog
2007-11-30 Tobias Burnus <burnus@net-b.de>
PR fortran/34133
* gfortran.dg/bind_c_usage_9.f03: Fixes; add -std=f2003.
* gfortran.dg/bind_c_usage_11.f03: New.
* gfortran.dg/bind_c_usage_12.f03: New.
2007-11-30 Jakub Jelinek <jakub@redhat.com>
PR c++/34275
gcc/testsuite/gfortran.dg/bind_c_usage_11.f03 0 → 100644
! { dg-do compile }
! { dg-options "-std=gnu" }
! PR fortran/34133
!
! The compiler should accept internal procedures with BIND(c) attribute
! for STD GNU / Fortran 2008.
!
subroutine foo() bind(c)
contains
subroutine bar() bind (c)
end subroutine bar
end subroutine foo
subroutine foo2() bind(c)
use iso_c_binding
contains
integer(c_int) function barbar() bind (c)
barbar = 1
end function barbar
end subroutine foo2
function one() bind(c)
use iso_c_binding
integer(c_int) :: one
one = 1
contains
integer(c_int) function two() bind (c)
two = 1
end function two
end function one
function one2() bind(c)
use iso_c_binding
integer(c_int) :: one2
one2 = 1
contains
subroutine three() bind (c)
end subroutine three
end function one2
program main
use iso_c_binding
implicit none
contains
subroutine test() bind(c)
end subroutine test
integer(c_int) function test2() bind (c)
test2 = 1
end function test2
end program main
gcc/testsuite/gfortran.dg/bind_c_usage_12.f03 0 → 100644
! { dg-do compile }
! { dg-options "-std=gnu" }
! PR fortran/34133
!
! bind(C,name="...") is invalid for dummy procedures
! and for internal procedures.
!
subroutine dummy1(a,b)
! implicit none
interface
function b() bind(c,name="jakl") ! { dg-error "no binding name is allowed" }
! use iso_c_binding
! integer(c_int) :: b
end function b ! { dg-error "Expecting END INTERFACE" }
end interface
interface
subroutine a() bind(c,name="") ! { dg-error "no binding name is allowed" }
end subroutine a ! { dg-error "Expecting END INTERFACE" }
end interface
end subroutine dummy1
subroutine internal()
implicit none
contains
subroutine int1() bind(c, name="jj") ! { dg-error "No binding name is allowed" }
end subroutine int1 ! { dg-error "Expected label" }
end subroutine internal
subroutine internal1()
use iso_c_binding
implicit none
contains
integer(c_int) function int2() bind(c, name="jjj") ! { dg-error "No binding name is allowed" }
end function int2 ! { dg-error "Expecting END SUBROUTINE" }
end subroutine internal1
integer(c_int) function internal2()
use iso_c_binding
implicit none
internal2 = 0
contains
subroutine int1() bind(c, name="kk") ! { dg-error "No binding name is allowed" }
end subroutine int1 ! { dg-error "Expecting END FUNCTION" }
end function internal2
integer(c_int) function internal3()
use iso_c_binding
implicit none
internal3 = 0
contains
integer(c_int) function int2() bind(c, name="kkk") ! { dg-error "No binding name is allowed" }
end function int2 ! { dg-error "Expected label" }
end function internal3
program internal_prog
use iso_c_binding
implicit none
contains
subroutine int1() bind(c, name="mm") ! { dg-error "No binding name is allowed" }
end subroutine int1 ! { dg-error "Expecting END PROGRAM statement" }
integer(c_int) function int2() bind(c, name="mmm") ! { dg-error "No binding name is allowed" }
end function int2 ! { dg-error "Expecting END PROGRAM statement" }
end program
gcc/testsuite/gfortran.dg/bind_c_usage_9.f03
! { dg-do compile }
! { dg-options "-std=f2003" }
! PR fortran/34133
!
! The compiler should reject internal procedures with BIND(c) attribute.
! The compiler should reject internal procedures with BIND(c) attribute
! for Fortran 2003.
!
subroutine foo() bind(c)
contains
......@@ -31,7 +33,7 @@ function one2() bind(c)
one2 = 1
contains
subroutine three() bind (c) ! { dg-error "may not be specified for an internal" }
end function three ! { dg-error "Expected label" }
end subroutine three ! { dg-error "Expecting END FUNCTION statement" }
end function one2 ! { dg-warning "Extension: CONTAINS statement" }
program main
......@@ -40,6 +42,6 @@ program main
contains
subroutine test() bind(c) ! { dg-error "may not be specified for an internal" }
end subroutine test ! { dg-error "Expecting END PROGRAM" }
function test2() bind (c) ! { dg-error "may not be specified for an internal" }
integer(c_int) function test2() bind (c) ! { dg-error "may not be specified for an internal" }
end function test2 ! { dg-error "Expecting END PROGRAM" }
end program main ! { dg-warning "Extension: CONTAINS statement" }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment