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

1 files changed, 215 insertions, 8 deletions

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)
     {