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

7 files changed, 199 insertions, 33 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6f23f68..564b738 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,16 @@
 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.
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 0da9cd2..e9b7651 100644
--- a/gcc/fortran/decl.c
+++ b/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);
     }
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index f9d6aea..5c4053cc 100644
--- a/gcc/fortran/match.h
+++ b/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.  */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 229fb0a..309fdec 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+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
diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_11.f03 b/gcc/testsuite/gfortran.dg/bind_c_usage_11.f03
new file mode 100644
index 0000000..466b71e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bind_c_usage_11.f03
@@ -0,0 +1,50 @@
+! { 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
diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_12.f03 b/gcc/testsuite/gfortran.dg/bind_c_usage_12.f03
new file mode 100644
index 0000000..8519c66
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bind_c_usage_12.f03
@@ -0,0 +1,63 @@
+! { 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
diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_9.f03 b/gcc/testsuite/gfortran.dg/bind_c_usage_9.f03
index f8682e8..0ab782e 100644
--- a/gcc/testsuite/gfortran.dg/bind_c_usage_9.f03
+++ b/gcc/testsuite/gfortran.dg/bind_c_usage_9.f03
@@ -1,7 +1,9 @@
 ! { 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" }