re PR fortran/36275 ([F03] Binding label can be any scalar char initialisation expression)

	PR fortran/36275
	PR fortran/38839

	* decl.c (check_bind_name_identifier): New function.
	(gfc_match_bind_c): Match any constant expression as binding
	label.
	* match.c (gfc_match_name_C): Remove.

	* gfortran.dg/binding_label_tests_2.f03: Adjust error messages.
	* gfortran.dg/binding_label_tests_27.f90: New file.

From-SVN: r212123

gcc/fortran/ChangeLog

+2014-06-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/36275
+	PR fortran/38839
+	* decl.c (check_bind_name_identifier): New function.
+	(gfc_match_bind_c): Match any constant expression as binding
+	label.
+	* match.c (gfc_match_name_C): Remove.
+
 2014-06-28  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
 	PR fortran/29383

gcc/fortran/decl.c

@@ -5779,6 +5779,54 @@ gfc_match_subroutine (void)
 }
 
 
+/* Check that the NAME identifier in a BIND attribute or statement
+   is conform to C identifier rules.  */
+
+match
+check_bind_name_identifier (char **name)
+{
+  char *n = *name, *p;
+
+  /* Remove leading spaces.  */
+  while (*n == ' ')
+    n++;
+
+  /* On an empty string, free memory and set name to NULL.  */
+  if (*n == '\0')
+    {
+      free (*name);
+      *name = NULL;
+      return MATCH_YES;
+    }
+
+  /* Remove trailing spaces.  */
+  p = n + strlen(n) - 1;
+  while (*p == ' ')
+    *(p--) = '\0';
+
+  /* Insert the identifier into the symbol table.  */
+  p = xstrdup (n);
+  free (*name);
+  *name = p;
+
+  /* Now check that identifier is valid under C rules.  */
+  if (ISDIGIT (*p))
+    {
+      gfc_error ("Invalid C identifier in NAME= specifier at %C");
+      return MATCH_ERROR;
+    }
+
+  for (; *p; p++)
+    if (!(ISALNUM (*p) || *p == '_' || *p == '$'))
+      {
+        gfc_error ("Invalid C identifier in NAME= specifier at %C");
+	return MATCH_ERROR;
+      }
+
+  return MATCH_YES;
+}
+
+
 /* Match a BIND(C) specifier, with the optional 'name=' specifier if
    given, and set the binding label in either the given symbol (if not
    NULL), or in the current_ts.  The symbol may be NULL because we may
@@ -5793,10 +5841,8 @@ gfc_match_subroutine (void)
 match
 gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
 {
-  /* binding label, if exists */
-  const char* binding_label = NULL;
-  match double_quote;
-  match single_quote;
+  char *binding_label = NULL;
+  gfc_expr *e = NULL;
 
   /* Initialize the flag that specifies whether we encountered a NAME=
      specifier or not.  */
@@ -5821,44 +5867,37 @@ gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
 
       has_name_equals = 1;
 
-      /* Get the opening quote.  */
-      double_quote = MATCH_YES;
-      single_quote = MATCH_YES;
-      double_quote = gfc_match_char ('"');
-      if (double_quote != MATCH_YES)
-	single_quote = gfc_match_char ('\'');
-      if (double_quote != MATCH_YES && single_quote != MATCH_YES)
-        {
-          gfc_error ("Syntax error in NAME= specifier for binding label "
-                     "at %C");
-          return MATCH_ERROR;
-        }
-
-      /* Grab the binding label, using functions that will not lower
-	 case the names automatically.	*/
-      if (gfc_match_name_C (&binding_label) != MATCH_YES)
-	 return MATCH_ERROR;
+      if (gfc_match_init_expr (&e) != MATCH_YES)
+	{
+	  gfc_free_expr (e);
+	  return MATCH_ERROR;
+	}
 
-      /* Get the closing quotation.  */
-      if (double_quote == MATCH_YES)
+      if (!gfc_simplify_expr(e, 0))
 	{
-	  if (gfc_match_char ('"') != MATCH_YES)
-            {
-              gfc_error ("Missing closing quote '\"' for binding label at %C");
-              /* User started string with '"' so looked to match it.  */
-              return MATCH_ERROR;
-            }
+	  gfc_error ("NAME= specifier at %C should be a constant expression");
+	  gfc_free_expr (e);
+	  return MATCH_ERROR;
 	}
-      else
+
+      if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER
+	  || e->ts.kind != gfc_default_character_kind || e->rank != 0)
 	{
-	  if (gfc_match_char ('\'') != MATCH_YES)
-            {
-              gfc_error ("Missing closing quote '\'' for binding label at %C");
-              /* User started string with "'" char.  */
-              return MATCH_ERROR;
-            }
+	  gfc_error ("NAME= specifier at %C should be a scalar of "
+	             "default character kind");
+	  gfc_free_expr(e);
+	  return MATCH_ERROR;
 	}
-   }
+
+      // Get a C string from the Fortran string constant
+      binding_label = gfc_widechar_to_char (e->value.character.string,
+					    e->value.character.length);
+      gfc_free_expr(e);
+
+      // Check that it is valid (old gfc_match_name_C)
+      if (check_bind_name_identifier (&binding_label) != MATCH_YES)
+	return MATCH_ERROR;
+    }
 
   /* Get the required right paren.  */
   if (gfc_match_char (')') != MATCH_YES)

gcc/fortran/match.c

@@ -569,99 +569,6 @@ gfc_match_name (char *buffer)
 }
 
 
-/* Match a valid name for C, which is almost the same as for Fortran,
-   except that you can start with an underscore, etc..  It could have
-   been done by modifying the gfc_match_name, but this way other
-   things C allows can be done, such as no limits on the length.
-   Also, by rewriting it, we use the gfc_next_char_C() to prevent the
-   input characters from being automatically lower cased, since C is
-   case sensitive.  The parameter, buffer, is used to return the name
-   that is matched.  Return MATCH_ERROR if the name is not a valid C
-   name, MATCH_NO if what we're seeing isn't a name, and MATCH_YES if
-   we successfully match a C name.  */
-
-match
-gfc_match_name_C (const char **buffer)
-{
-  locus old_loc;
-  size_t i = 0;
-  gfc_char_t c;
-  char* buf;
-  size_t cursz = 16;
-
-  old_loc = gfc_current_locus;
-  gfc_gobble_whitespace ();
-
-  /* Get the next char (first possible char of name) and see if
-     it's valid for C (either a letter or an underscore).  */
-  c = gfc_next_char_literal (INSTRING_WARN);
-
-  /* If the user put nothing expect spaces between the quotes, it is valid
-     and simply means there is no name= specifier and the name is the Fortran
-     symbol name, all lowercase.  */
-  if (c == '"' || c == '\'')
-    {
-      gfc_current_locus = old_loc;
-      return MATCH_YES;
-    }
-
-  if (!ISALPHA (c) && c != '_')
-    {
-      gfc_error ("Invalid C name in NAME= specifier at %C");
-      return MATCH_ERROR;
-    }
-
-  buf = XNEWVEC (char, cursz);
-  /* Continue to read valid variable name characters.  */
-  do
-    {
-      gcc_assert (gfc_wide_fits_in_byte (c));
-
-      buf[i++] = (unsigned char) c;
-
-      if (i >= cursz)
-	{
-	  cursz *= 2;
-	  buf = XRESIZEVEC (char, buf, cursz);
-	}
-
-      old_loc = gfc_current_locus;
-
-      /* Get next char; param means we're in a string.  */
-      c = gfc_next_char_literal (INSTRING_WARN);
-    } while (ISALNUM (c) || c == '_');
-
-  /* The binding label will be needed later anyway, so just insert it
-     into the symbol table.  */
-  buf[i] = '\0';
-  *buffer = IDENTIFIER_POINTER (get_identifier (buf));
-  XDELETEVEC (buf);
-  gfc_current_locus = old_loc;
-
-  /* See if we stopped because of whitespace.  */
-  if (c == ' ')
-    {
-      gfc_gobble_whitespace ();
-      c = gfc_peek_ascii_char ();
-      if (c != '"' && c != '\'')
-        {
-          gfc_error ("Embedded space in NAME= specifier at %C");
-          return MATCH_ERROR;
-        }
-    }
-
-  /* If we stopped because we had an invalid character for a C name, report
-     that to the user by returning MATCH_NO.  */
-  if (c != '"' && c != '\'')
-    {
-      gfc_error ("Invalid C name in NAME= specifier at %C");
-      return MATCH_ERROR;
-    }
-
-  return MATCH_YES;
-}
-
-
 /* Match a symbol on the input.  Modifies the pointer to the symbol
    pointer if successful.  */
 

gcc/testsuite/ChangeLog

+2014-06-29  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/36275
+	PR fortran/38839
+	* gfortran.dg/binding_label_tests_2.f03: Adjust error messages.
+	* gfortran.dg/binding_label_tests_27.f90: New file.
+
 2014-06-29  Andreas Schwab  <schwab@linux-m68k.org>
 
 	* gfortran.dg/ieee/ieee_6.f90: Allow inexact together with

gcc/testsuite/gfortran.dg/binding_label_tests_2.f03

@@ -7,25 +7,28 @@ contains
   subroutine ok() 
   end subroutine ok
 
-  subroutine sub0() bind(c, name="   1") ! { dg-error "Invalid C name" }
+  subroutine sub0() bind(c, name="   1") ! { dg-error "Invalid C identifier" }
   end subroutine sub0 ! { dg-error "Expecting END MODULE" }
 
-  subroutine sub1() bind(c, name="$") ! { dg-error "Invalid C name" }
-  end subroutine sub1 ! { dg-error "Expecting END MODULE" }
+  subroutine sub1() bind(c, name="$")
+  end subroutine sub1
 
-  subroutine sub2() bind(c, name="abc$") ! { dg-error "Invalid C name" }
-  end subroutine sub2 ! { dg-error "Expecting END MODULE" }
+  subroutine sub2() bind(c, name="abc$")
+  end subroutine sub2
 
-  subroutine sub3() bind(c, name="abc d") ! { dg-error "Embedded space" }
+  subroutine sub3() bind(c, name="abc d") ! { dg-error "Invalid C identifier" }
   end subroutine sub3 ! { dg-error "Expecting END MODULE" }
 
-  subroutine sub5() BIND(C, name=" myvar 2 ") ! { dg-error "Embedded space" }
+  subroutine sub4() bind(c, name="2foo") ! { dg-error "Invalid C identifier" }
+  end subroutine sub4 ! { dg-error "Expecting END MODULE" }
+
+  subroutine sub5() BIND(C, name=" myvar 2 ") ! { dg-error "Invalid C identifier" }
   end subroutine sub5 ! { dg-error "Expecting END MODULE" }
 
-  subroutine sub6() bind(c, name="         ) ! { dg-error "Invalid C name" }
+  subroutine sub6() bind(c, name="         ) ! { dg-error "Invalid C identifier" }
   end subroutine sub6 ! { dg-error "Expecting END MODULE" }
 
-  subroutine sub7() bind(c, name=) ! { dg-error "Syntax error" }
+  subroutine sub7() bind(c, name=) ! { dg-error "Invalid character" }
   end subroutine sub7 ! { dg-error "Expecting END MODULE" }
 
   subroutine sub8() bind(c, name) ! { dg-error "Syntax error" }

gcc/testsuite/gfortran.dg/binding_label_tests_27.f90

+! { dg-do compile }
+
+module p
+
+  implicit none
+  integer i1, i2, i3, i4, i5, i6, i7, i8, i9, i10
+
+  character(len=*), parameter :: s = "toto"
+  character(len=*), parameter :: t(2) = ["x", "y"]
+
+  bind(c,name="   foo    ") :: i1
+  bind(c, name=trim("Hello   ") // "There") :: i2
+  bind(c, name=1_"name") :: i3
+  bind(c, name=4_"") :: i4 ! { dg-error "scalar of default character kind" }
+  bind(c, name=1) :: i5 ! { dg-error "scalar of default character kind" }
+  bind(c, name=1.0) :: i6 ! { dg-error "scalar of default character kind" }
+  bind(c, name=["","",""]) :: i7 ! { dg-error "scalar of default character kind" }
+  bind(c, name=s) :: i8
+  bind(c, name=t(2)) :: i9
+
+end module
+
+subroutine foobar(s)
+  character(len=*) :: s
+  integer :: i
+  bind(c, name=s) :: i ! { dg-error "constant expression" }
+end subroutine