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

gcc/fortran/ChangeLog

+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-16  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/34796

gcc/fortran/decl.c

@@ -86,8 +86,7 @@ static enumerator_history *max_enum = NULL;
 
 gfc_symbol *gfc_new_block;
 
-locus gfc_function_kind_locus;
-locus gfc_function_type_locus;
+bool gfc_matching_function;
 
 
 /********************* DATA statement subroutines *********************/
@@ -653,6 +652,12 @@ match_char_length (gfc_expr **expr)
     goto syntax;
 
   m = char_len_param_value (expr);
+  if (m != MATCH_YES && gfc_matching_function)
+    {
+      gfc_undo_symbols ();
+      m = MATCH_YES;
+    }
+
   if (m == MATCH_ERROR)
     return m;
   if (m == MATCH_NO)
@@ -1869,13 +1874,11 @@ kind_expr:
 
   if (n != MATCH_YES)
     {
-      if (gfc_current_state () == COMP_INTERFACE
-            || gfc_current_state () == COMP_NONE
-            || gfc_current_state () == COMP_CONTAINS)
+      if (gfc_matching_function)
 	{
-	  /* Signal using kind = -1 that the expression might include
-	     use associated or imported parameters and try again after
-	     the specification expressions.....  */
+	  /* The function kind expression might include use associated or 
+	     imported parameters and try again after the specification
+	     expressions.....  */
 	  if (gfc_match_char (')') != MATCH_YES)
 	    {
 	      gfc_error ("Missing right parenthesis at %C");
@@ -1884,8 +1887,6 @@ kind_expr:
 	    }
 
 	  gfc_free_expr (e);
-	  ts->kind = -1;
-	  gfc_function_kind_locus = loc;
 	  gfc_undo_symbols ();
 	  return MATCH_YES;
 	}
@@ -1907,6 +1908,7 @@ kind_expr:
     }
 
   msg = gfc_extract_int (e, &ts->kind);
+
   if (msg != NULL)
     {
       gfc_error (msg);
@@ -1977,17 +1979,12 @@ match_char_kind (int * kind, int * is_iso_c)
 
   n = gfc_match_init_expr (&e);
 
-  if (n != MATCH_YES
-      && (gfc_current_state () == COMP_INTERFACE
-	  || gfc_current_state () == COMP_NONE
-	  || gfc_current_state () == COMP_CONTAINS))
+  if (n != MATCH_YES && gfc_matching_function)
     {
-      /* Signal using kind = -1 that the expression might include
-	 use-associated or imported parameters and try again after
-	 the specification expressions.  */
+      /* The expression might include use-associated or imported
+	 parameters and try again after the specification 
+	 expressions.  */
       gfc_free_expr (e);
-      *kind = -1;
-      gfc_function_kind_locus = where;
       gfc_undo_symbols ();
       return MATCH_YES;
     }
@@ -2154,6 +2151,17 @@ syntax:
   return m;
 
 done:
+  /* Except in the case of the length being a function, where symbol
+     association looks after itself, deal with character functions
+     after the specification statements.  */
+  if (gfc_matching_function
+	&& !(len && len->expr_type != EXPR_VARIABLE
+		 && len->expr_type != EXPR_OP))
+    {
+      gfc_undo_symbols ();
+      return MATCH_YES;
+    }
+
   if (m != MATCH_YES)
     {
       gfc_free_expr (len);
@@ -2209,9 +2217,16 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
   gfc_symbol *sym;
   match m;
   int c;
-  locus loc = gfc_current_locus;
+  bool seen_deferred_kind;
 
+  /* A belt and braces check that the typespec is correctly being treated
+     as a deferred characteristic association.  */
+  seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
+					&& (gfc_current_block ()->result->ts.kind == -1)
+					&& (ts->kind == -1);
   gfc_clear_ts (ts);
+  if (seen_deferred_kind)
+    ts->kind = -1;
 
   /* Clear the current binding label, in case one is given.  */
   curr_binding_label[0] = '\0';
@@ -2293,18 +2308,24 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
   if (m != MATCH_YES)
     return m;
 
-  if (gfc_current_state () == COMP_INTERFACE
-	|| gfc_current_state () == COMP_NONE)
+  ts->type = BT_DERIVED;
+
+  /* Defer association of the derived type until the end of the
+     specification block.  However, if the derived type can be
+     found, add it to the typespec.  */  
+  if (gfc_matching_function)
     {
-      gfc_function_type_locus = loc;
-      ts->type = BT_UNKNOWN;
-      ts->kind = -1;
+      ts->derived = NULL;
+      if (gfc_current_state () != COMP_INTERFACE
+	    && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
+	ts->derived = sym;
       return MATCH_YES;
     }
 
   /* Search for the name but allow the components to be defined later.  If
      type = -1, this typespec has been seen in a function declaration but
-     the type could not legally be accessed at that point.  */
+     the type could not be accessed at that point.  */
+  sym = NULL;
   if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
     {
       gfc_error ("Type name '%s' at %C is ambiguous", name);
@@ -2312,12 +2333,15 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
     }
   else if (ts->kind == -1)
     {
-      if (gfc_find_symbol (name, NULL, 0, &sym))
+      int iface = gfc_state_stack->previous->state != COMP_INTERFACE
+		    || gfc_current_ns->has_import_set;
+      if (gfc_find_symbol (name, NULL, iface, &sym))
 	{       
 	  gfc_error ("Type name '%s' at %C is ambiguous", name);
 	  return MATCH_ERROR;
 	}
 
+      ts->kind = 0;
       if (sym == NULL)
 	return MATCH_NO;
     }
@@ -2326,8 +2350,7 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
       && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
     return MATCH_ERROR;
 
-  ts->type = BT_DERIVED;
-  ts->kind = 0;
+  gfc_set_sym_referenced (sym);
   ts->derived = sym;
 
   return MATCH_YES;
@@ -2350,6 +2373,12 @@ get_kind:
   if (m == MATCH_NO && ts->type != BT_CHARACTER)
     m = gfc_match_old_kind_spec (ts);
 
+  /* Defer association of the KIND expression of function results
+     until after USE and IMPORT statements.  */
+  if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
+	 || gfc_matching_function)
+    return MATCH_YES;
+
   if (m == MATCH_NO)
     m = MATCH_YES;		/* No kind specifier found.  */
 
@@ -3673,8 +3702,8 @@ cleanup:
    can be matched.  Note that if nothing matches, MATCH_YES is
    returned (the null string was matched).  */
 
-static match
-match_prefix (gfc_typespec *ts)
+match
+gfc_match_prefix (gfc_typespec *ts)
 {
   bool seen_type;
 
@@ -3720,7 +3749,7 @@ loop:
 }
 
 
-/* Copy attributes matched by match_prefix() to attributes on a symbol.  */
+/* Copy attributes matched by gfc_match_prefix() to attributes on a symbol.  */
 
 static try
 copy_prefix (symbol_attribute *dest, locus *where)
@@ -4245,7 +4274,7 @@ gfc_match_function_decl (void)
 
   old_loc = gfc_current_locus;
 
-  m = match_prefix (&current_ts);
+  m = gfc_match_prefix (&current_ts);
   if (m != MATCH_YES)
     {
       gfc_current_locus = old_loc;
@@ -4329,6 +4358,22 @@ gfc_match_function_decl (void)
 	  goto cleanup;
 	}
 
+      /* Except in the case of a function valued character length,
+	 delay matching the function characteristics until after the
+	 specification block by signalling kind=-1.  */
+      if (!(current_ts.type == BT_CHARACTER
+	      && current_ts.cl
+	      && current_ts.cl->length
+	      && current_ts.cl->length->expr_type != EXPR_OP
+	      && current_ts.cl->length->expr_type != EXPR_VARIABLE))
+	{
+	  sym->declared_at = old_loc;
+	  if (current_ts.type != BT_UNKNOWN)
+	    current_ts.kind = -1;
+	  else
+	    current_ts.kind = 0;
+	}
+
       if (result == NULL)
 	{
 	  sym->ts = current_ts;
@@ -4635,7 +4680,7 @@ gfc_match_subroutine (void)
       && gfc_current_state () != COMP_CONTAINS)
     return MATCH_NO;
 
-  m = match_prefix (NULL);
+  m = gfc_match_prefix (NULL);
   if (m != MATCH_YES)
     return m;
 

gcc/fortran/gfortran.h

@@ -223,7 +223,7 @@ typedef enum
   ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
   ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE,
   ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_PROCEDURE,
-  ST_NONE
+  ST_GET_FCN_CHARACTERISTICS, ST_NONE
 }
 gfc_statement;
 

gcc/fortran/misc.c

@@ -74,8 +74,8 @@ void
 gfc_clear_ts (gfc_typespec *ts)
 {
   ts->type = BT_UNKNOWN;
-  ts->kind = 0;
   ts->derived = NULL;
+  ts->kind = 0;
   ts->cl = NULL;
   /* flag that says if the type is C interoperable */
   ts->is_c_interop = 0;

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;

gcc/fortran/parse.h

@@ -66,7 +66,6 @@ const char *gfc_ascii_statement (gfc_statement);
 match gfc_match_enum (void);
 match gfc_match_enumerator_def (void);
 void gfc_free_enum_history (void);
-extern locus gfc_function_kind_locus;
-extern locus gfc_function_type_locus;
-
+extern bool gfc_matching_function;
+match gfc_match_prefix (gfc_typespec *);
 #endif  /* GFC_PARSE_H  */

gcc/testsuite/ChangeLog

+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.
+
 2008-01-16  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gnat.dg/sizetype.adb: New test.

gcc/testsuite/gfortran.dg/auto_internal_assumed.f90

@@ -3,10 +3,10 @@
 ! internal function.
 !
 character (6) :: c
-  c = f1 ()        ! { dg-error "must not be assumed length" }
+  c = f1 ()
   if (c .ne. 'abcdef') call abort
 contains
-  function f1 ()
+  function f1 () ! { dg-error "must not be assumed length" }
     character (*) :: f1
     f1 = 'abcdef'
   end function f1

gcc/testsuite/gfortran.dg/defined_operators_1.f90

@@ -7,10 +7,10 @@
 !
 module mymod
   interface operator (.foo.)
-     module procedure foo_0 ! { dg-error "must have at least one argument" }
-     module procedure foo_1 ! { dg-error "must be INTENT" }
-     module procedure foo_2 ! { dg-error "cannot be optional" }
-     module procedure foo_3 ! { dg-error "must have, at most, two arguments" }
+     module procedure foo_0
+     module procedure foo_1
+     module procedure foo_2
+     module procedure foo_3
      module procedure foo_1_OK  ! { dg-error "Ambiguous interfaces" }
      module procedure foo_2_OK
      function foo_chr (chr) ! { dg-error "cannot be assumed character length" }
@@ -22,11 +22,11 @@ module mymod
      end subroutine bad_foo
   end interface
 contains
-  function foo_0 ()
+  function foo_0 () ! { dg-error "must have at least one argument" }
     integer :: foo_1
     foo_0 = 1
   end function foo_0
-  function foo_1 (a)
+  function foo_1 (a) ! { dg-error "must be INTENT" }
     integer :: foo_1
     integer :: a
     foo_1 = 1
@@ -36,7 +36,7 @@ contains
     integer, intent (in) :: a
     foo_1_OK = 1
   end function foo_1_OK
-  function foo_2 (a, b)
+  function foo_2 (a, b) ! { dg-error "cannot be optional" }
     integer :: foo_2
     integer, intent(in) :: a
     integer, intent(in), optional :: b
@@ -48,7 +48,7 @@ contains
     real, intent(in) :: b
     foo_2_OK = 2.0 * a + b
   end function foo_2_OK
-  function foo_3 (a, b, c)
+  function foo_3 (a, b, c) ! { dg-error "must have, at most, two arguments" }
     integer :: foo_3
     integer, intent(in) :: a, b, c
     foo_3 = a + 3 * b - c

gcc/testsuite/gfortran.dg/elemental_args_check_2.f90

@@ -8,10 +8,10 @@
 MODULE M1
 IMPLICIT NONE
 CONTAINS
- PURE ELEMENTAL SUBROUTINE S1(I,F) ! { dg-error "Dummy procedure 'f' not allowed in elemental procedure" }
+ PURE ELEMENTAL SUBROUTINE S1(I,F)
    INTEGER, INTENT(IN) :: I
    INTERFACE
-     PURE INTEGER FUNCTION F(I)
+     PURE INTEGER FUNCTION F(I) ! { dg-error "Dummy procedure 'f' not allowed in elemental procedure" }
       INTEGER, INTENT(IN) :: I
      END FUNCTION F
    END INTERFACE

gcc/testsuite/gfortran.dg/function_charlen_1.f90

+! { dg-do compile }
+! Tests the fix for PR34429 in which function charlens that were
+! USE associated would cause an error.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+module m
+  integer, parameter :: strlen = 5
+end module m
+
+character(strlen) function test()
+  use m
+  test = 'A'
+end function test
+
+  interface
+    character(strlen) function test()
+      use m
+    end function test
+  end interface
+  print *, test()
+end
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/function_kinds_4.f90

+! { dg-do run }
+! Tests the fix for PR34471 in which function KINDs that were
+! USE associated would cause an error.
+!
+! This only needs to be run once.
+! { dg-options "-O2" }
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+module m1
+  integer, parameter :: i1 = 1, i2 = 2
+end module m1
+
+module m2
+  integer, parameter :: i1 = 8
+end module m2
+
+integer(i1) function three()
+  use m1, only: i2
+  use m2                ! This provides the function kind
+  three = i1
+  if(three /= kind(three)) call abort()
+end function three
+
+! At one stage during the development of the patch, this started failing
+! but was not tested in gfortran.dg.  */
+real (kind(0d0)) function foo ()
+  foo = real (kind (foo))
+end function
+
+program main
+implicit none
+ interface
+    integer(8) function three()
+    end function three
+ end interface
+ integer, parameter :: i1 = 4
+ integer :: i
+ real (kind(0d0)) foo
+ i = one()
+ i = two()
+ if(three() /= 8) call abort()
+ if (int(foo()) /= 8) call abort ()
+contains
+ integer(i1) function one()  ! Host associated kind
+   if (kind(one) /= 4) call abort()
+   one = 1
+ end function one
+ integer(i1) function two()  ! Use associated kind
+   use m1, only: i2
+   use m2
+   if (kind(two) /= 8) call abort()
+   two = 1
+ end function two
+end program main
+! { dg-final { cleanup-modules "m1 m2" } }

gcc/testsuite/gfortran.dg/function_kinds_5.f90

+! { dg-do compile }
+! Tests the fix for PR34471 in which function KINDs that were
+! USE associated would cause an error.  This checks a regression
+! caused by an intermediate version of the patch.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+real (bad_kind(0d0)) function foo () ! { dg-error "must be an intrinsic or" }
+  foo = real (kind (foo))
+end function

gcc/testsuite/gfortran.dg/function_types_1.f90

+! { dg-do compile }
+! Tests the fix for PR34431 in which function TYPEs that were
+! USE associated would cause an error.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+module bar
+contains
+  type(non_exist) function func2() ! { dg-error "not accessible" }
+  end function func2
+end module bar
+! { dg-final { cleanup-modules "bar" } }

gcc/testsuite/gfortran.dg/function_types_2.f90

+! { dg-do compile }
+! Tests the fix for PR34431 in which function TYPEs that were
+! USE associated would cause an error.
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+!
+module m1
+  integer :: hh
+  type t
+    real :: r
+  end type t
+end module m1
+
+module m2
+  type t
+    integer :: k
+  end type t
+end module m2
+
+module m3
+contains
+  type(t) function func()
+    use m2
+    func%k = 77
+  end function func
+end module m3
+
+type(t) function a()
+  use m1, only: hh
+  type t2
+    integer :: j
+  end type t2
+  type t
+    logical :: b
+  end type t
+
+  a%b = .true.
+end function a
+
+type(t) function b()
+  use m1, only: hh
+  use m2
+  use m3
+  b = func ()
+  b%k = 5
+end function b
+
+type(t) function c()
+  use m1, only: hh
+  type t2
+    integer :: j
+  end type t2
+  type t
+    logical :: b
+  end type t
+
+  c%b = .true.
+end function c
+
+program main
+  type t
+    integer :: m
+  end type t
+contains
+  type(t) function a1()
+    use m1, only: hh
+    type t2
+      integer :: j
+    end type t2
+    type t
+      logical :: b
+    end type t
+
+    a1%b = .true.
+  end function a1
+
+  type(t) function b1()
+    use m1, only: hh
+    use m2, only: t
+! NAG f95 believes that the host-associated type(t)
+! should be used:
+!   b1%m = 5
+! However, I (Tobias Burnus) believe that the use-associated one should
+! be used:
+    b1%k = 5
+  end function b1
+
+  type(t) function c1()
+    use m1, only: hh
+    type t2
+      integer :: j
+    end type t2
+    type t
+      logical :: b
+    end type t
+
+    c1%b = .true.
+  end function c1
+
+  type(t) function d1()
+    d1%m = 55
+  end function d1
+end program main
+! { dg-final { cleanup-modules "m1 m2 m3" } }

gcc/testsuite/gfortran.dg/interface_15.f90

@@ -8,12 +8,12 @@ MODULE M1
     INTEGER :: I
   END TYPE T1
   INTERFACE I
-    MODULE PROCEDURE F1        ! { dg-error "PUBLIC interface" }
+    MODULE PROCEDURE F1
   END INTERFACE
   PRIVATE ! :: T1,F1
   PUBLIC  :: I
 CONTAINS
-  INTEGER FUNCTION F1(D)
+  INTEGER FUNCTION F1(D)  ! { dg-error "PUBLIC interface" }
     TYPE(T1) :: D
     F1 = D%I
   END FUNCTION

gcc/testsuite/gfortran.dg/private_type_4.f90

@@ -7,11 +7,11 @@ module m1
     end type t1
 
     private :: t1
-    public :: f1     ! { dg-error "cannot be of PRIVATE type" }
+    public :: f1
 
 contains
 
-    type(t1) function f1()
+    type(t1) function f1() ! { dg-error "cannot be of PRIVATE type" }
     end function
 
 end module