re PR fortran/34429 (Fails: character(len=use_associated_const) function foo())

2008-01-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/34429
	PR fortran/34431
	PR fortran/34471
	* decl.c : Remove gfc_function_kind_locus and
	gfc_function_type_locus. Add gfc_matching_function.
	(match_char_length): If matching a function and the length
	does not match, return MATCH_YES and try again later.
	(gfc_match_kind_spec): The same.
	(match_char_kind): The same.
	(gfc_match_type_spec): The same for numeric and derived types.
	(match_prefix): Rename as gfc_match_prefix.
	(gfc_match_function_decl): Except for function valued character
	lengths, defer applying kind, type and charlen info until the
	end of specification block.
	gfortran.h (gfc_statement): Add ST_GET_FCN_CHARACTERISTICS.
	parse.c (decode_specification_statement): New function.
	(decode_statement): Call it when a function has kind = -1. Set
	and reset gfc_matching function, as function statement is being
	matched.
	(match_deferred_characteristics): Simplify with a single call
	to gfc_match_prefix. Do appropriate error handling. In any
	case, make sure that kind = -1 is reset or corrected.
	(parse_spec): Call above on seeing ST_GET_FCN_CHARACTERISTICS.
	Throw an error if kind = -1 after last specification statement.
	parse.h : Prototype for gfc_match_prefix.

2008-01-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/34429
	* gfortran.dg/function_charlen_1.f90: New test.

	PR fortran/34431
	* gfortran.dg/function_types_1.f90: New test.
	* gfortran.dg/function_types_2.f90: New test.

	PR fortran/34471
	* gfortran.dg/function_kinds_4.f90: New test.
	* gfortran.dg/function_kinds_5.f90: New test.

	* gfortran.dg/defined_operators_1.f90: Errors now at function
	declarations.
	* gfortran.dg/private_type_4.f90: The same.
	* gfortran.dg/interface_15.f90: The same.
	* gfortran.dg/elemental_args_check_2.f90: The same.
	* gfortran.dg/auto_internal_assumed.f90: The same.

From-SVN: r131592

1 files changed, 202 insertions, 28 deletions

diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index c941b4e..e57e10d 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -85,6 +85,144 @@ match_word (const char *str, match (*subr) (void), locus *old_locus)
 	undo_new_statement ();				  \
     } while (0);
 
+
+/* This is a specialist version of decode_statement that is used
+   for the specification statements in a function, whose
+   characteristics are deferred into the specification statements.
+   eg.:  INTEGER (king = mykind) foo ()
+	 USE mymodule, ONLY mykind..... 
+   The KIND parameter needs a return after USE or IMPORT, whereas
+   derived type declarations can occur anywhere, up the executable
+   block.  ST_GET_FCN_CHARACTERISTICS is returned when we have run
+   out of the correct kind of specification statements.  */
+static gfc_statement
+decode_specification_statement (void)
+{
+  gfc_statement st;
+  locus old_locus;
+  int c;
+
+  if (gfc_match_eos () == MATCH_YES)
+    return ST_NONE;
+
+  old_locus = gfc_current_locus;
+
+  match ("import", gfc_match_import, ST_IMPORT);
+  match ("use", gfc_match_use, ST_USE);
+
+  if (gfc_numeric_ts (&gfc_current_block ()->ts))
+    goto end_of_block;
+
+  match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
+  match (NULL, gfc_match_data_decl, ST_DATA_DECL);
+  match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
+
+  /* General statement matching: Instead of testing every possible
+     statement, we eliminate most possibilities by peeking at the
+     first character.  */
+
+  c = gfc_peek_char ();
+
+  switch (c)
+    {
+    case 'a':
+      match ("abstract% interface", gfc_match_abstract_interface,
+	     ST_INTERFACE);
+      break;
+
+    case 'b':
+      match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
+      break;
+
+    case 'c':
+      break;
+
+    case 'd':
+      match ("data", gfc_match_data, ST_DATA);
+      match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
+      break;
+
+    case 'e':
+      match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
+      match ("entry% ", gfc_match_entry, ST_ENTRY);
+      match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
+      match ("external", gfc_match_external, ST_ATTR_DECL);
+      break;
+
+    case 'f':
+      match ("format", gfc_match_format, ST_FORMAT);
+      break;
+
+    case 'g':
+      break;
+
+    case 'i':
+      match ("implicit", gfc_match_implicit, ST_IMPLICIT);
+      match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
+      match ("interface", gfc_match_interface, ST_INTERFACE);
+      match ("intent", gfc_match_intent, ST_ATTR_DECL);
+      match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
+      break;
+
+    case 'm':
+      break;
+
+    case 'n':
+      match ("namelist", gfc_match_namelist, ST_NAMELIST);
+      break;
+
+    case 'o':
+      match ("optional", gfc_match_optional, ST_ATTR_DECL);
+      break;
+
+    case 'p':
+      match ("parameter", gfc_match_parameter, ST_PARAMETER);
+      match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
+      if (gfc_match_private (&st) == MATCH_YES)
+	return st;
+      match ("procedure", gfc_match_procedure, ST_PROCEDURE);
+      if (gfc_match_public (&st) == MATCH_YES)
+	return st;
+      match ("protected", gfc_match_protected, ST_ATTR_DECL);
+      break;
+
+    case 'r':
+      break;
+
+    case 's':
+      match ("save", gfc_match_save, ST_ATTR_DECL);
+      break;
+
+    case 't':
+      match ("target", gfc_match_target, ST_ATTR_DECL);
+      match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
+      break;
+
+    case 'u':
+      break;
+
+    case 'v':
+      match ("value", gfc_match_value, ST_ATTR_DECL);
+      match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
+      break;
+
+    case 'w':
+      break;
+    }
+
+  /* This is not a specification statement.  See if any of the matchers
+     has stored an error message of some sort.  */
+
+end_of_block:
+  gfc_clear_error ();
+  gfc_buffer_error (0);
+  gfc_current_locus = old_locus;
+
+  return ST_GET_FCN_CHARACTERISTICS;
+}
+
+
+/* This is the primary 'decode_statement'.  */
 static gfc_statement
 decode_statement (void)
 {
@@ -100,9 +238,15 @@ decode_statement (void)
   gfc_clear_error ();	/* Clear any pending errors.  */
   gfc_clear_warning ();	/* Clear any pending warnings.  */
 
+  gfc_matching_function = false;
+
   if (gfc_match_eos () == MATCH_YES)
     return ST_NONE;
 
+  if (gfc_current_state () == COMP_FUNCTION
+	&& gfc_current_block ()->result->ts.kind == -1)
+    return decode_specification_statement ();
+
   old_locus = gfc_current_locus;
 
   /* Try matching a data declaration or function declaration. The
@@ -113,6 +257,7 @@ decode_statement (void)
       || gfc_current_state () == COMP_INTERFACE
       || gfc_current_state () == COMP_CONTAINS)
     {
+      gfc_matching_function = true;
       m = gfc_match_function_decl ();
       if (m == MATCH_YES)
 	return ST_FUNCTION;
@@ -122,6 +267,8 @@ decode_statement (void)
 	gfc_undo_symbols ();
       gfc_current_locus = old_locus;
     }
+  gfc_matching_function = false;
+
 
   /* Match statements whose error messages are meant to be overwritten
      by something better.  */
@@ -1870,30 +2017,48 @@ done:
 }
 
 
-/* Recover use associated or imported function characteristics.  */
+/* Associate function characteristics by going back to the function
+   declaration and rematching the prefix.  */
 
-static try
+static match
 match_deferred_characteristics (gfc_typespec * ts)
 {
   locus loc;
-  match m;
+  match m = MATCH_ERROR;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
 
   loc = gfc_current_locus;
 
-  if (gfc_current_block ()->ts.type != BT_UNKNOWN)
+  gfc_current_locus = gfc_current_block ()->declared_at;
+
+  gfc_clear_error ();
+  gfc_buffer_error (1);
+  m = gfc_match_prefix (ts);
+  gfc_buffer_error (0);
+
+  if (ts->type == BT_DERIVED)
     {
-      /* Kind expression for an intrinsic type.  */
-      gfc_current_locus = gfc_function_kind_locus;
-      m = gfc_match_kind_spec (ts, true);
+      ts->kind = 0;
+
+      if (!ts->derived || !ts->derived->components)
+	m = MATCH_ERROR;
     }
-  else
+
+  /* Only permit one go at the characteristic association.  */
+  if (ts->kind == -1)
+    ts->kind = 0;
+
+  /* Set the function locus correctly.  If we have not found the
+     function name, there is an error.  */
+  gfc_match ("function% %n", name);
+  if (m == MATCH_YES && strcmp (name, gfc_current_block ()->name) == 0)
     {
-      /* A derived type.  */
-      gfc_current_locus = gfc_function_type_locus;
-      m = gfc_match_type_spec (ts, 0);
+      gfc_current_block ()->declared_at = gfc_current_locus;
+      gfc_commit_symbols ();
     }
+  else
+    gfc_error_check ();
 
-  gfc_current_ns->proc_name->result->ts = *ts;
   gfc_current_locus =loc;
   return m;
 }
@@ -1906,6 +2071,8 @@ static gfc_statement
 parse_spec (gfc_statement st)
 {
   st_state ss;
+  bool bad_characteristic = false;
+  gfc_typespec *ts;
 
   verify_st_order (&ss, ST_NONE);
   if (st == ST_NONE)
@@ -1984,15 +2151,6 @@ loop:
 	}
 
       accept_statement (st);
-
-      /* Look out for function kind/type information that used
-	 use associated or imported parameter.  This is signalled
-	 by kind = -1.  */
-      if (gfc_current_state () == COMP_FUNCTION
-	    && (st == ST_USE || st == ST_IMPORT || st == ST_DERIVED_DECL)
-	    && gfc_current_block ()->ts.kind == -1)
-	match_deferred_characteristics (&gfc_current_block ()->ts);
-
       st = next_statement ();
       goto loop;
 
@@ -2002,21 +2160,37 @@ loop:
       st = next_statement ();
       goto loop;
 
+    case ST_GET_FCN_CHARACTERISTICS:
+      /* This statement triggers the association of a function's result
+	 characteristics.  */
+      ts = &gfc_current_block ()->result->ts;
+      if (match_deferred_characteristics (ts) != MATCH_YES)
+	bad_characteristic = true;
+
+      st = next_statement ();
+      goto loop;
+
     default:
       break;
     }
 
-  /* If we still have kind = -1 at the end of the specification block,
-     then there is an error. */
-  if (gfc_current_state () == COMP_FUNCTION
-	&& gfc_current_block ()->ts.kind == -1)
+  /* If match_deferred_characteristics failed, then there is an error. */
+  if (bad_characteristic)
     {
-      if (gfc_current_block ()->ts.type != BT_UNKNOWN)
+      ts = &gfc_current_block ()->result->ts;
+      if (ts->type != BT_DERIVED)
 	gfc_error ("Bad kind expression for function '%s' at %L",
-		   gfc_current_block ()->name, &gfc_function_kind_locus);
+		   gfc_current_block ()->name,
+		   &gfc_current_block ()->declared_at);
       else
 	gfc_error ("The type for function '%s' at %L is not accessible",
-		   gfc_current_block ()->name, &gfc_function_type_locus);
+		   gfc_current_block ()->name,
+		   &gfc_current_block ()->declared_at);
+
+      gfc_current_block ()->ts.kind = 0;
+      /* Keep the derived type; if it's bad, it will be discovered later.  */
+      if (!(ts->type = BT_DERIVED && ts->derived))
+        ts->type = BT_UNKNOWN;
     }
 
   return st;