re PR fortran/34079 (Bind(C): Character argument/return value problems)

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

        PR fortran/34079
        * decl.c (gfc_match_entry): Support BIND(C).
        (gfc_match_subroutine): Fix comment typo.

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

        PR fortran/34079
        * gfortran.dg/bind_c_usage_10_c.c: New.
        * gfortran.dg/bind_c_usage_10.f03: New.

From-SVN: r130288

gcc/fortran/ChangeLog

+2007-11-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34079
+	* decl.c (gfc_match_entry): Support BIND(C).
+	(gfc_match_subroutine): Fix comment typo.
+
 2007-11-18  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/33317

gcc/fortran/decl.c

@@ -4315,6 +4315,8 @@ gfc_match_entry (void)
   gfc_entry_list *el;
   locus old_loc;
   bool module_procedure;
+  char peek_char;
+  match is_bind_c;
 
   m = gfc_match_name (name);
   if (m != MATCH_YES)
@@ -4398,6 +4400,26 @@ gfc_match_entry (void)
 
   proc = gfc_current_block ();
 
+  /* Make sure that it isn't already declared as BIND(C).  If it is, it
+     must have been marked BIND(C) with a BIND(C) attribute and that is
+     not allowed for procedures.  */
+  if (entry->attr.is_bind_c == 1)
+    {
+      entry->attr.is_bind_c = 0;
+      if (entry->old_symbol != NULL)
+        gfc_error_now ("BIND(C) attribute at %L can only be used for "
+                       "variables or common blocks",
+                       &(entry->old_symbol->declared_at));
+      else
+        gfc_error_now ("BIND(C) attribute at %L can only be used for "
+                       "variables or common blocks", &gfc_current_locus);
+    }
+  
+  /* Check what next non-whitespace character is so we can tell if there
+     is the required parens if we have a BIND(C).  */
+  gfc_gobble_whitespace ();
+  peek_char = gfc_peek_char ();
+
   if (state == COMP_SUBROUTINE)
     {
       /* An entry in a subroutine.  */
@@ -4408,6 +4430,21 @@ gfc_match_entry (void)
       if (m != MATCH_YES)
 	return MATCH_ERROR;
 
+      is_bind_c = gfc_match_bind_c (entry);
+      if (is_bind_c == MATCH_ERROR)
+	return MATCH_ERROR;
+      if (is_bind_c == MATCH_YES)
+	{
+	  if (peek_char != '(')
+	    {
+	      gfc_error ("Missing required parentheses before BIND(C) at %C");
+	      return MATCH_ERROR;
+	    }
+	    if (gfc_add_is_bind_c (&(entry->attr), entry->name, &(entry->declared_at), 1)
+		== FAILURE)
+	      return MATCH_ERROR;
+	}
+
       if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
 	  || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
 	return MATCH_ERROR;
@@ -4452,19 +4489,28 @@ gfc_match_entry (void)
 	}
       else
 	{
-	  m = match_result (proc, &result);
+	  m = gfc_match_suffix (entry, &result);
 	  if (m == MATCH_NO)
 	    gfc_syntax_error (ST_ENTRY);
 	  if (m != MATCH_YES)
 	    return MATCH_ERROR;
 
-	  if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
-	      || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
-	      || gfc_add_function (&entry->attr, result->name, NULL)
-		 == FAILURE)
-	    return MATCH_ERROR;
-
-	  entry->result = result;
+          if (result)
+	    {
+	      if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
+		  || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
+		  || gfc_add_function (&entry->attr, result->name, NULL)
+		  == FAILURE)
+	        return MATCH_ERROR;
+	      entry->result = result;
+	    }
+	  else
+	    {
+	      if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
+		  || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
+		return MATCH_ERROR;
+	      entry->result = entry;
+	    }
 	}
     }
 
@@ -4523,7 +4569,7 @@ gfc_match_subroutine (void)
   gfc_new_block = sym;
 
   /* Check what next non-whitespace character is so we can tell if there
-     where the required parens if we have a BIND(C).  */
+     is the required parens if we have a BIND(C).  */
   gfc_gobble_whitespace ();
   peek_char = gfc_peek_char ();
   

gcc/testsuite/ChangeLog

+2007-11-19  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/34079
+	* gfortran.dg/bind_c_usage_10_c.c: New.
+	* gfortran.dg/bind_c_usage_10.f03: New.
+
 2007-11-19  Eric Botcazou  <ebotcazou@libertysurf.fr>
 
 	* gcc.dg/pr33007.c: Expect new warning.

gcc/testsuite/gfortran.dg/bind_c_usage_10.f03

+! { dg-do run }
+! { dg-additional-sources bind_c_usage_10_c.c }
+!
+! PR fortran/34079
+!
+! Check BIND(C) for ENTRY
+!
+module mod
+ use iso_c_binding
+ implicit none
+contains
+  subroutine sub1(j) bind(c, name="mySub1")
+    integer(c_int) :: j
+    real(c_float)  :: x
+    j = 5
+    return
+   entry sub1ent(x)
+     x = 55.0
+  end subroutine sub1
+  subroutine sub2(j)
+    integer(c_int) :: j
+    real(c_float)  :: x
+    j = 6
+    return
+   entry sub2ent(x) bind(c, name="mySubEnt2")
+    x = 66.0
+  end subroutine sub2
+  subroutine sub3(j) bind(c, name="mySub3")
+    integer(c_int) :: j
+    real(c_float)  :: x
+    j = 7
+    return
+   entry sub3ent(x) bind(c, name="mySubEnt3")
+     x = 77.0
+  end subroutine sub3
+  subroutine sub4(j)
+    integer(c_int) :: j
+    real(c_float)  :: x
+    j = 8
+    return
+   entry sub4ent(x) bind(c)
+     x = 88.0
+  end subroutine sub4
+
+  integer(c_int) function func1() bind(c, name="myFunc1")
+    real(c_float) :: func1ent
+    func1 = -5
+    return
+   entry func1ent()
+    func1ent = -55.0
+  end function func1
+  integer(c_int) function func2()
+    real(c_float) :: func2ent
+    func2 = -6
+    return
+   entry func2ent() bind(c, name="myFuncEnt2")
+    func2ent = -66.0
+  end function func2
+  integer(c_int) function func3() bind(c, name="myFunc3")
+    real(c_float) :: func3ent
+    func3 = -7
+    return
+   entry func3ent() bind(c, name="myFuncEnt3")
+    func3ent = -77.0
+  end function func3
+  integer(c_int) function func4()
+    real(c_float) :: func4ent
+    func4 = -8
+    return
+   entry func4ent() bind(c)
+    func4ent = -88.0
+  end function func4
+end module mod

gcc/testsuite/gfortran.dg/bind_c_usage_10_c.c

+/* Check BIND(C) for ENTRY
+   PR fortran/34079
+   To be linked with bind_c_usage_10.c
+*/
+
+void mySub1(int *);
+void mySub3(int *);
+void mySubEnt2(float *);
+void mySubEnt3(float *);
+void sub4ent(float *);
+
+int myFunc1(void);
+int myFunc3(void);
+float myFuncEnt2(void);
+float myFuncEnt3(void);
+float func4ent(void);
+
+extern void abort(void);
+
+int main()
+{
+  int i = -1;
+  float r = -3.0f;
+
+  mySub1(&i);
+  if(i != 5) abort();
+  mySub3(&i);
+  if(i != 7) abort();
+  mySubEnt2(&r);
+  if(r != 66.0f) abort();
+  mySubEnt3(&r);
+  if(r != 77.0f) abort();
+  sub4ent(&r);
+  if(r != 88.0f) abort();
+
+  i = myFunc1();
+  if(i != -5) abort();
+  i = myFunc3();
+  if(i != -7) abort();
+  r = myFuncEnt2();
+  if(r != -66.0f) abort();
+  r = myFuncEnt3();
+  if(r != -77.0f) abort();
+  r = func4ent();
+  if(r != -88.0f) abort();
+
+  return 0;
+}