PR fortran/33529

	* decl.c (match_char_kind): New function.
	(match_char_spec): Use match_char_kind.

	* gfortran.dg/char_type_len_2.f90: Adjust error message.
	* gfortran.dg/char_decl_2.f90: New test.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@129012 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d9e368b..488d280 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,11 @@
 2007-10-04  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
+       PR fortran/33529
+       * decl.c (match_char_kind): New function.
+       (match_char_spec): Use match_char_kind.
+
+2007-10-04  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
        PR fortran/33502
        * scanner.c (gfc_advance_line): Call debug_hooks->end_source_file
        and debug_hooks->start_source_file when appropriate, and set

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index a507137..d0eb0ef 100644 (file)
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1886,20 +1886,80 @@ no_match:
 }
 
 
+static match
+match_char_kind (int * kind, int * is_iso_c)
+{
+  locus where;
+  gfc_expr *e;
+  match m, n;
+  const char *msg;
+
+  m = MATCH_NO;
+  e = NULL;
+  where = gfc_current_locus;
+
+  n = gfc_match_init_expr (&e);
+  if (n == MATCH_NO)
+    gfc_error ("Expected initialization expression at %C");
+  if (n != MATCH_YES)
+    return MATCH_ERROR;
+
+  if (e->rank != 0)
+    {
+      gfc_error ("Expected scalar initialization expression at %C");
+      m = MATCH_ERROR;
+      goto no_match;
+    }
+
+  msg = gfc_extract_int (e, kind);
+  *is_iso_c = e->ts.is_iso_c;
+  if (msg != NULL)
+    {
+      gfc_error (msg);
+      m = MATCH_ERROR;
+      goto no_match;
+    }
+
+  gfc_free_expr (e);
+
+  /* Ignore errors to this point, if we've gotten here.  This means
+     we ignore the m=MATCH_ERROR from above.  */
+  if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
+    {
+      gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
+      m = MATCH_ERROR;
+    }
+  else
+     /* All tests passed.  */
+     m = MATCH_YES;
+
+  if (m == MATCH_ERROR)
+     gfc_current_locus = where;
+  
+  /* Return what we know from the test(s).  */
+  return m;
+
+no_match:
+  gfc_free_expr (e);
+  gfc_current_locus = where;
+  return m;
+}
+
 /* Match the various kind/length specifications in a CHARACTER
    declaration.  We don't return MATCH_NO.  */
 
 static match
 match_char_spec (gfc_typespec *ts)
 {
-  int kind, seen_length;
+  int kind, seen_length, is_iso_c;
   gfc_charlen *cl;
   gfc_expr *len;
   match m;
-  gfc_expr *kind_expr = NULL;
-  kind = gfc_default_character_kind;
+
   len = NULL;
   seen_length = 0;
+  kind = 0;
+  is_iso_c = 0;
 
   /* Try the old-style specification first.  */
   old_char_selector = 0;
@@ -1923,7 +1983,7 @@ match_char_spec (gfc_typespec *ts)
   /* Try the weird case:  ( KIND = <int> [ , LEN = <len-param> ] ).  */
   if (gfc_match (" kind =") == MATCH_YES)
     {
-      m = gfc_match_small_int_expr(&kind, &kind_expr);
+      m = match_char_kind (&kind, &is_iso_c);
        
       if (m == MATCH_ERROR)
        goto done;
@@ -1959,13 +2019,8 @@ match_char_spec (gfc_typespec *ts)
       if (gfc_match (" , kind =") != MATCH_YES)
        goto syntax;
 
-      gfc_match_small_int_expr(&kind, &kind_expr);
-
-      if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
-       {
-         gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
-         return MATCH_YES;
-       }
+      if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
+       goto done;
 
       goto rparen;
     }
@@ -1987,7 +2042,7 @@ match_char_spec (gfc_typespec *ts)
 
   gfc_match (" kind =");       /* Gobble optional text.  */
 
-  m = gfc_match_small_int_expr(&kind, &kind_expr);
+  m = match_char_kind (&kind, &is_iso_c);
   if (m == MATCH_ERROR)
     goto done;
   if (m == MATCH_NO)
@@ -2006,23 +2061,9 @@ syntax:
   return m;
 
 done:
-  if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
-    {
-      gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
-      m = MATCH_ERROR;
-    }
-
-  if (seen_length == 1 && len != NULL
-      && len->ts.type != BT_INTEGER && len->ts.type != BT_UNKNOWN)
-    {
-      gfc_error ("Expression at %C must be of INTEGER type");
-      m = MATCH_ERROR;
-    }
-
   if (m != MATCH_YES)
     {
       gfc_free_expr (len);
-      gfc_free_expr (kind_expr);
       return m;
     }
 
@@ -2037,30 +2078,24 @@ done:
     cl->length = len;
 
   ts->cl = cl;
-  ts->kind = kind;
+  ts->kind = kind == 0 ? gfc_default_character_kind : kind;
 
   /* We have to know if it was a c interoperable kind so we can
      do accurate type checking of bind(c) procs, etc.  */
-  if (kind_expr != NULL)
-    {
-      /* Mark this as c interoperable if being declared with one
-        of the named constants from iso_c_binding.  */
-      ts->is_c_interop = kind_expr->ts.is_iso_c;
-      gfc_free_expr (kind_expr);
-    }
+  if (kind != 0)
+    /* Mark this as c interoperable if being declared with one
+       of the named constants from iso_c_binding.  */
+    ts->is_c_interop = is_iso_c;
   else if (len != NULL)
-    {
-      /* Here, we might have parsed something such as:
-        character(c_char)
-        In this case, the parsing code above grabs the c_char when
-        looking for the length (line 1690, roughly).  it's the last
-        testcase for parsing the kind params of a character variable.
-        However, it's not actually the length.  this seems like it
-        could be an error.  
-        To see if the user used a C interop kind, test the expr
-        of the so called length, and see if it's C interoperable.  */
-      ts->is_c_interop = len->ts.is_iso_c;
-    }
+    /* Here, we might have parsed something such as: character(c_char)
+       In this case, the parsing code above grabs the c_char when
+       looking for the length (line 1690, roughly).  it's the last
+       testcase for parsing the kind params of a character variable.
+       However, it's not actually the length.   this seems like it
+       could be an error.  
+       To see if the user used a C interop kind, test the expr
+       of the so called length, and see if it's C interoperable.  */
+    ts->is_c_interop = len->ts.is_iso_c;
   
   return MATCH_YES;
 }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 5f1e3d7..6e5dba0 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2007-10-04  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+       PR fortran/33529
+       * gfortran.dg/char_type_len_2.f90: Adjust error message.
+       * gfortran.dg/char_decl_2.f90: New test.
+
 2007-10-04  Richard Guenther  <rguenther@suse.de>
 
        PR middle-end/33641

diff --git a/gcc/testsuite/gfortran.dg/char_decl_2.f90 b/gcc/testsuite/gfortran.dg/char_decl_2.f90
new file mode 100644 (file)
index 0000000..ffce6b1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/char_decl_2.f90
@@ -0,0 +1,4 @@
+! { dg-do run }
+  character (kind=kind("a")) :: u
+  if (kind(u) /= kind("a")) call abort
+  end

diff --git a/gcc/testsuite/gfortran.dg/char_type_len_2.f90 b/gcc/testsuite/gfortran.dg/char_type_len_2.f90
index a5cb835..e4fab80 100644 (file)
--- a/gcc/testsuite/gfortran.dg/char_type_len_2.f90
+++ b/gcc/testsuite/gfortran.dg/char_type_len_2.f90
@@ -2,7 +2,9 @@
 ! PR31251 Non-integer character length leads to segfault
 ! Submitted by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
   character(len=2.3) :: s ! { dg-error "must be of INTEGER type" }
-  character(kind=1,len=4.3) : t ! { dg-error "must be of INTEGER type" }
-  character(len=,,7.2,kind=1) : u ! { dg-error "Syntax error in CHARACTER declaration" }
-  character(len=7,kind=2) : v ! ! { dg-error "Kind 2 is not a CHARACTER kind" }
+  character(kind=1,len=4.3) :: t ! { dg-error "must be of INTEGER type" }
+  character(len=,,7.2,kind=1) :: u ! { dg-error "Syntax error in CHARACTER declaration" }
+  character(len=7,kind=2) :: v ! ! { dg-error "Kind 2 is not supported for CHARACTER" }
+  character(kind=2) :: w ! ! { dg-error "Kind 2 is not supported for CHARACTER" }
+  character(kind=2,len=7) :: x ! ! { dg-error "Kind 2 is not supported for CHARACTER" }
   end