re PR fortran/16161 ([gfortran] IMPLICIT CHARACTER not implemented)

fortran/
PR fortran/16161
* decl.c (gfc_match_type_spec): Rename second argument to
'implicit_flag', reverse meaning. Don't match_char_spec if
'implicit_flag' is set. Rename to ...
(match_type_spec): ... this.
(gfc_match_implicit_none, match_implicit_range): Move here
from match.c.
(gfc_match_implicit): Move here from match.c, try to
match_char_len if match_implicit_range doesn't succeed for
CHARACTER implicits. Call renamed fucntion match_type_spec.
(gfc_match_data_decl, match_prefix): Call renamed function
match_type_spec.
* match.c (gfc_match_implicit_none, match_implicit_range,
gfc_match_implicit): Move to decl.c.
* match.h (gfc_match_implicit_none, gfc_match_implicit):
Move protoypes to section 'decl.c'.
(gfc_match_type_spec): Remove prototype.

testsuite/
PR fortran/16161
* gfortran.fortran-torture/compile/implicit.f90: Add test
for implicit character.

From-SVN: r83907

4 files changed, 238 insertions, 209 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 4c56afb..8e65b69 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,23 @@
+2004-06-30  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+	PR fortran/16161
+	* decl.c (gfc_match_type_spec): Rename second argument to
+	'implicit_flag', reverse meaning. Don't match_char_spec if
+	'implicit_flag' is set. Rename to ...
+	(match_type_spec): ... this.
+	(gfc_match_implicit_none, match_implicit_range): Move here
+	from match.c.
+	(gfc_match_implicit): Move here from match.c, try to
+	match_char_len if match_implicit_range doesn't succeed for
+	CHARACTER implicits. Call renamed fucntion match_type_spec.
+	(gfc_match_data_decl, match_prefix): Call renamed function
+	match_type_spec.
+	* match.c (gfc_match_implicit_none, match_implicit_range,
+	gfc_match_implicit): Move to decl.c.
+	* match.h (gfc_match_implicit_none, gfc_match_implicit):
+	Move protoypes to section 'decl.c'.
+	(gfc_match_type_spec): Remove prototype.
+
 2004-06-29  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
 
 	* decl.c, interface.c, symbol.c, trans-common.c: Add 2004 to 
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index cc65d07..5c5b728 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -874,12 +874,12 @@ done:
    to the matched specification.  This is necessary for FUNCTION and
    IMPLICIT statements.
 
-   If kind_flag is nonzero, then we check for the optional kind
-   specification.  Not doing so is needed for matching an IMPLICIT
+   If implicit_flag is nonzero, then we don't check for the optional 
+   kind specification.  Not doing so is needed for matching an IMPLICIT
    statement correctly.  */
 
-match
-gfc_match_type_spec (gfc_typespec * ts, int kind_flag)
+static match
+match_type_spec (gfc_typespec * ts, int implicit_flag)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_symbol *sym;
@@ -898,7 +898,10 @@ gfc_match_type_spec (gfc_typespec * ts, int kind_flag)
   if (gfc_match (" character") == MATCH_YES)
     {
       ts->type = BT_CHARACTER;
-      return match_char_spec (ts);
+      if (implicit_flag == 0)
+	return match_char_spec (ts);
+      else
+	return MATCH_YES;
     }
 
   if (gfc_match (" real") == MATCH_YES)
@@ -960,7 +963,7 @@ gfc_match_type_spec (gfc_typespec * ts, int kind_flag)
 get_kind:
   /* For all types except double, derived and character, look for an
      optional kind specifier.  MATCH_NO is actually OK at this point.  */
-  if (kind_flag == 0)
+  if (implicit_flag == 1)
     return MATCH_YES;
 
   if (gfc_current_form == FORM_FREE)
@@ -982,6 +985,210 @@ get_kind:
 }
 
 
+/* Match an IMPLICIT NONE statement.  Actually, this statement is
+   already matched in parse.c, or we would not end up here in the
+   first place.  So the only thing we need to check, is if there is
+   trailing garbage.  If not, the match is successful.  */
+
+match
+gfc_match_implicit_none (void)
+{
+
+  return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
+}
+
+
+/* Match the letter range(s) of an IMPLICIT statement.  */
+
+static match
+match_implicit_range (gfc_typespec * ts)
+{
+  int c, c1, c2, inner;
+  locus cur_loc;
+
+  cur_loc = gfc_current_locus;
+
+  gfc_gobble_whitespace ();
+  c = gfc_next_char ();
+  if (c != '(')
+    {
+      gfc_error ("Missing character range in IMPLICIT at %C");
+      goto bad;
+    }
+
+  inner = 1;
+  while (inner)
+    {
+      gfc_gobble_whitespace ();
+      c1 = gfc_next_char ();
+      if (!ISALPHA (c1))
+	goto bad;
+
+      gfc_gobble_whitespace ();
+      c = gfc_next_char ();
+
+      switch (c)
+	{
+	case ')':
+	  inner = 0;		/* Fall through */
+
+	case ',':
+	  c2 = c1;
+	  break;
+
+	case '-':
+	  gfc_gobble_whitespace ();
+	  c2 = gfc_next_char ();
+	  if (!ISALPHA (c2))
+	    goto bad;
+
+	  gfc_gobble_whitespace ();
+	  c = gfc_next_char ();
+
+	  if ((c != ',') && (c != ')'))
+	    goto bad;
+	  if (c == ')')
+	    inner = 0;
+
+	  break;
+
+	default:
+	  goto bad;
+	}
+
+      if (c1 > c2)
+	{
+	  gfc_error ("Letters must be in alphabetic order in "
+		     "IMPLICIT statement at %C");
+	  goto bad;
+	}
+
+      /* See if we can add the newly matched range to the pending
+         implicits from this IMPLICIT statement.  We do not check for
+         conflicts with whatever earlier IMPLICIT statements may have
+         set.  This is done when we've successfully finished matching
+         the current one.  */
+      if (gfc_add_new_implicit_range (c1, c2, ts) != SUCCESS)
+	goto bad;
+    }
+
+  return MATCH_YES;
+
+bad:
+  gfc_syntax_error (ST_IMPLICIT);
+
+  gfc_current_locus = cur_loc;
+  return MATCH_ERROR;
+}
+
+
+/* Match an IMPLICIT statement, storing the types for
+   gfc_set_implicit() if the statement is accepted by the parser.
+   There is a strange looking, but legal syntactic construction
+   possible.  It looks like:
+
+     IMPLICIT INTEGER (a-b) (c-d)
+
+   This is legal if "a-b" is a constant expression that happens to
+   equal one of the legal kinds for integers.  The real problem
+   happens with an implicit specification that looks like:
+
+     IMPLICIT INTEGER (a-b)
+
+   In this case, a typespec matcher that is "greedy" (as most of the
+   matchers are) gobbles the character range as a kindspec, leaving
+   nothing left.  We therefore have to go a bit more slowly in the
+   matching process by inhibiting the kindspec checking during
+   typespec matching and checking for a kind later.  */
+
+match
+gfc_match_implicit (void)
+{
+  gfc_typespec ts;
+  locus cur_loc;
+  int c;
+  match m;
+
+  /* We don't allow empty implicit statements.  */
+  if (gfc_match_eos () == MATCH_YES)
+    {
+      gfc_error ("Empty IMPLICIT statement at %C");
+      return MATCH_ERROR;
+    }
+
+  /* First cleanup.  */
+  gfc_clear_new_implicit ();
+
+  do
+    {
+      /* A basic type is mandatory here.  */
+      m = match_type_spec (&ts, 1);
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      cur_loc = gfc_current_locus;
+      m = match_implicit_range (&ts);
+
+      if (m != MATCH_YES && ts.type == BT_CHARACTER)
+	{
+	  /* looks like we are matching CHARACTER (<len>) (<range>)  */
+	  m = match_char_spec (&ts);
+	}	  
+
+      if (m == MATCH_YES)
+	{
+	  /* Looks like we have the <TYPE> (<RANGE>).  */
+	  gfc_gobble_whitespace ();
+	  c = gfc_next_char ();
+	  if ((c == '\n') || (c == ','))
+	    continue;
+
+	  gfc_current_locus = cur_loc;
+	}
+
+      /* Last chance -- check <TYPE> (<KIND>) (<RANGE>).  */
+      m = gfc_match_kind_spec (&ts);
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_NO)
+	{
+	  m = gfc_match_old_kind_spec (&ts);
+	  if (m == MATCH_ERROR)
+	    goto error;
+	  if (m == MATCH_NO)
+	    goto syntax;
+	}
+
+      m = match_implicit_range (&ts);
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_NO)
+	goto syntax;
+
+      gfc_gobble_whitespace ();
+      c = gfc_next_char ();
+      if ((c != '\n') && (c != ','))
+	goto syntax;
+
+    }
+  while (c == ',');
+
+  /* All we need to now is try to merge the new implicit types back
+     into the existing types.  This will fail if another implicit
+     type is already defined for a letter.  */
+  return (gfc_merge_new_implicit () == SUCCESS) ?
+      MATCH_YES : MATCH_ERROR;
+
+syntax:
+  gfc_syntax_error (ST_IMPLICIT);
+
+error:
+  return MATCH_ERROR;
+}
+
+
 /* Matches an attribute specification including array specs.  If
    successful, leaves the variables current_attr and current_as
    holding the specification.  Also sets the colon_seen variable for
@@ -1242,7 +1449,7 @@ gfc_match_data_decl (void)
   gfc_symbol *sym;
   match m;
 
-  m = gfc_match_type_spec (&current_ts, 1);
+  m = match_type_spec (&current_ts, 0);
   if (m != MATCH_YES)
     return m;
 
@@ -1332,7 +1539,7 @@ match_prefix (gfc_typespec * ts)
 
 loop:
   if (!seen_type && ts != NULL
-      && gfc_match_type_spec (ts, 1) == MATCH_YES
+      && match_type_spec (ts, 0) == MATCH_YES
       && gfc_match_space () == MATCH_YES)
     {
 
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index d605361..9bc1f4f 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -2048,204 +2048,6 @@ cleanup:
 }
 
 
-/* Match an IMPLICIT NONE statement.  Actually, this statement is
-   already matched in parse.c, or we would not end up here in the
-   first place.  So the only thing we need to check, is if there is
-   trailing garbage.  If not, the match is successful.  */
-
-match
-gfc_match_implicit_none (void)
-{
-
-  return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
-}
-
-
-/* Match the letter range(s) of an IMPLICIT statement.  */
-
-static match
-match_implicit_range (gfc_typespec * ts)
-{
-  int c, c1, c2, inner;
-  locus cur_loc;
-
-  cur_loc = gfc_current_locus;
-
-  gfc_gobble_whitespace ();
-  c = gfc_next_char ();
-  if (c != '(')
-    {
-      gfc_error ("Missing character range in IMPLICIT at %C");
-      goto bad;
-    }
-
-  inner = 1;
-  while (inner)
-    {
-      gfc_gobble_whitespace ();
-      c1 = gfc_next_char ();
-      if (!ISALPHA (c1))
-	goto bad;
-
-      gfc_gobble_whitespace ();
-      c = gfc_next_char ();
-
-      switch (c)
-	{
-	case ')':
-	  inner = 0;		/* Fall through */
-
-	case ',':
-	  c2 = c1;
-	  break;
-
-	case '-':
-	  gfc_gobble_whitespace ();
-	  c2 = gfc_next_char ();
-	  if (!ISALPHA (c2))
-	    goto bad;
-
-	  gfc_gobble_whitespace ();
-	  c = gfc_next_char ();
-
-	  if ((c != ',') && (c != ')'))
-	    goto bad;
-	  if (c == ')')
-	    inner = 0;
-
-	  break;
-
-	default:
-	  goto bad;
-	}
-
-      if (c1 > c2)
-	{
-	  gfc_error ("Letters must be in alphabetic order in "
-		     "IMPLICIT statement at %C");
-	  goto bad;
-	}
-
-      /* See if we can add the newly matched range to the pending
-         implicits from this IMPLICIT statement.  We do not check for
-         conflicts with whatever earlier IMPLICIT statements may have
-         set.  This is done when we've successfully finished matching
-         the current one.  */
-      if (gfc_add_new_implicit_range (c1, c2, ts) != SUCCESS)
-	goto bad;
-    }
-
-  return MATCH_YES;
-
-bad:
-  gfc_syntax_error (ST_IMPLICIT);
-
-  gfc_current_locus = cur_loc;
-  return MATCH_ERROR;
-}
-
-
-/* Match an IMPLICIT statement, storing the types for
-   gfc_set_implicit() if the statement is accepted by the parser.
-   There is a strange looking, but legal syntactic construction
-   possible.  It looks like:
-
-     IMPLICIT INTEGER (a-b) (c-d)
-
-   This is legal if "a-b" is a constant expression that happens to
-   equal one of the legal kinds for integers.  The real problem
-   happens with an implicit specification that looks like:
-
-     IMPLICIT INTEGER (a-b)
-
-   In this case, a typespec matcher that is "greedy" (as most of the
-   matchers are) gobbles the character range as a kindspec, leaving
-   nothing left.  We therefore have to go a bit more slowly in the
-   matching process by inhibiting the kindspec checking during
-   typespec matching and checking for a kind later.  */
-
-match
-gfc_match_implicit (void)
-{
-  gfc_typespec ts;
-  locus cur_loc;
-  int c;
-  match m;
-
-  /* We don't allow empty implicit statements.  */
-  if (gfc_match_eos () == MATCH_YES)
-    {
-      gfc_error ("Empty IMPLICIT statement at %C");
-      return MATCH_ERROR;
-    }
-
-  /* First cleanup.  */
-  gfc_clear_new_implicit ();
-
-  do
-    {
-      /* A basic type is mandatory here.  */
-      m = gfc_match_type_spec (&ts, 0);
-      if (m == MATCH_ERROR)
-	goto error;
-      if (m == MATCH_NO)
-	goto syntax;
-
-      cur_loc = gfc_current_locus;
-      m = match_implicit_range (&ts);
-
-      if (m == MATCH_YES)
-	{
-	  /* Looks like we have the <TYPE> (<RANGE>).  */
-	  gfc_gobble_whitespace ();
-	  c = gfc_next_char ();
-	  if ((c == '\n') || (c == ','))
-	    continue;
-
-	  gfc_current_locus = cur_loc;
-	}
-
-      /* Last chance -- check <TYPE> (<KIND>) (<RANGE>).  */
-      m = gfc_match_kind_spec (&ts);
-      if (m == MATCH_ERROR)
-	goto error;
-      if (m == MATCH_NO)
-	{
-	  m = gfc_match_old_kind_spec (&ts);
-	  if (m == MATCH_ERROR)
-	    goto error;
-	  if (m == MATCH_NO)
-	    goto syntax;
-	}
-
-      m = match_implicit_range (&ts);
-      if (m == MATCH_ERROR)
-	goto error;
-      if (m == MATCH_NO)
-	goto syntax;
-
-      gfc_gobble_whitespace ();
-      c = gfc_next_char ();
-      if ((c != '\n') && (c != ','))
-	goto syntax;
-
-    }
-  while (c == ',');
-
-  /* All we need to now is try to merge the new implicit types back
-     into the existing types.  This will fail if another implicit
-     type is already defined for a letter.  */
-  return (gfc_merge_new_implicit () == SUCCESS) ?
-      MATCH_YES : MATCH_ERROR;
-
-syntax:
-  gfc_syntax_error (ST_IMPLICIT);
-
-error:
-  return MATCH_ERROR;
-}
-
-
 /* Given a name, return a pointer to the common head structure,
    creating it if it does not exist.
    TODO: Add to global symbol tree.  */
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 85729ec..4b8f872 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -75,8 +75,6 @@ match gfc_match_deallocate (void);
 match gfc_match_return (void);
 match gfc_match_call (void);
 match gfc_match_common (void);
-match gfc_match_implicit_none (void);
-match gfc_match_implicit (void);
 match gfc_match_block_data (void);
 match gfc_match_namelist (void);
 match gfc_match_module (void);
@@ -98,7 +96,6 @@ gfc_common_head *gfc_get_common (char *);
 match gfc_match_null (gfc_expr **);
 match gfc_match_kind_spec (gfc_typespec *);
 match gfc_match_old_kind_spec (gfc_typespec *);
-match gfc_match_type_spec (gfc_typespec *, int);
 
 match gfc_match_end (gfc_statement *);
 match gfc_match_data_decl (void);
@@ -108,6 +105,9 @@ match gfc_match_entry (void);
 match gfc_match_subroutine (void);
 match gfc_match_derived_decl (void);
 
+match gfc_match_implicit_none (void);
+match gfc_match_implicit (void);
+
 /* Matchers for attribute declarations */
 match gfc_match_allocatable (void);
 match gfc_match_dimension (void);