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)
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)
{
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;
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':
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;
}
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. */
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;
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)
match m;
match is_bind_c;
char peek_char;
+ bool allow_binding_name;
if (gfc_current_state () != COMP_NONE
&& gfc_current_state () != COMP_INTERFACE
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
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");
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];
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. */
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);
}
--- /dev/null
+! { 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
projects / thirdparty / gcc.git / commitdiff
