re PR fortran/32095 (Accepts invalid character(len(a)),dimension(1) :: a)

2008-08-22  Daniel Kraft  <d@domob.eu>

	PR fortran/32095
	PR fortran/34228
	* gfortran.h (in_prefix): New global.
	(gfc_check_symbol_typed), (gfc_check_expr_typed): New methods.
	* array.c (match_array_element_spec): Check that bounds-expressions
	don't have symbols not-yet-typed in them.
	* decl.c (var_element): Check that variable used is already typed.
	(char_len_param_value): Check that expression does not contain
	not-yet-typed symbols.
	(in_prefix): New global.
	(gfc_match_prefix): Record using `in_prefix' if we're at the moment
	parsing a prefix or not.
	* expr.c (gfc_expr_check_typed): New method.
	* parse.c (verify_st_order): New argument to disable error output.
	(check_function_result_typed): New helper method.
	(parse_spec): Check that the function-result declaration, if given in
	a prefix, contains no not-yet-typed symbols when the IMPLICIT rules are
	parsed.
	* symbol.c (gfc_check_symbol_typed): Check that a symbol already has
	a type associated to it, otherwise use the IMPLICIT rules or signal
	an error.

2008-08-22  Daniel Kraft  <d@domob.eu>

	PR fortran/32095
	PR fortran/34228
	* gfortran.dg/used_before_typed_1.f90: New test.
	* gfortran.dg/used_before_typed_2.f90: New test.
	* gfortran.dg/used_before_typed_3.f90: New test.
	* gfortran.dg/array_constructor_26.f03: Add -std=gnu to not enable
	legacy-behaviour for the new check.
	* gfortran.dg/array_constructor_27.f03: Ditto.
	* gfortran.dg/blockdata_4.f90: Ditto.
	* gfortran.dg/bound_2.f90: Reordered declarations to satisfy the check.
	* gfortran.dg/result_in_spec_1.f90: Ditto.
	* gfortran.dg/argument_checking_7.f90: Adapted expected error messages.

From-SVN: r139425

7 files changed, 247 insertions, 12 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 6a2865b..30329d0 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,27 @@
+2008-08-22  Daniel Kraft  <d@domob.eu>
+
+	PR fortran/32095
+	PR fortran/34228
+	* gfortran.h (in_prefix): New global.
+	(gfc_check_symbol_typed), (gfc_check_expr_typed): New methods.
+	* array.c (match_array_element_spec): Check that bounds-expressions
+	don't have symbols not-yet-typed in them.
+	* decl.c (var_element): Check that variable used is already typed.
+	(char_len_param_value): Check that expression does not contain
+	not-yet-typed symbols.
+	(in_prefix): New global.
+	(gfc_match_prefix): Record using `in_prefix' if we're at the moment
+	parsing a prefix or not.
+	* expr.c (gfc_expr_check_typed): New method.
+	* parse.c (verify_st_order): New argument to disable error output.
+	(check_function_result_typed): New helper method.
+	(parse_spec): Check that the function-result declaration, if given in
+	a prefix, contains no not-yet-typed symbols when the IMPLICIT rules are
+	parsed.
+	* symbol.c (gfc_check_symbol_typed): Check that a symbol already has
+	a type associated to it, otherwise use the IMPLICIT rules or signal
+	an error.
+
 2008-08-21  Manuel Lopez-Ibanez  <manu@gcc.gnu.org>
 
 	* f95-lang.c: Update all calls to pedwarn.
diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 1cafe2b..d99ed9e 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -314,6 +314,8 @@ match_array_element_spec (gfc_array_spec *as)
     gfc_error ("Expected expression in array specification at %C");
   if (m != MATCH_YES)
     return AS_UNKNOWN;
+  if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
+    return AS_UNKNOWN;
 
   if (gfc_match_char (':') == MATCH_NO)
     {
@@ -332,6 +334,8 @@ match_array_element_spec (gfc_array_spec *as)
     return AS_UNKNOWN;
   if (m == MATCH_NO)
     return AS_ASSUMED_SHAPE;
+  if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
+    return AS_UNKNOWN;
 
   return AS_EXPLICIT;
 }
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 1249780..892c8f3 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -247,6 +247,11 @@ var_element (gfc_data_variable *new_var)
 
   sym = new_var->expr->symtree->n.sym;
 
+  /* Symbol should already have an associated type.  */
+  if (gfc_check_symbol_typed (sym, gfc_current_ns,
+			      false, gfc_current_locus) == FAILURE)
+    return MATCH_ERROR;
+
   if (!sym->attr.function && gfc_current_ns->parent
       && gfc_current_ns->parent == sym->ns)
     {
@@ -598,6 +603,11 @@ char_len_param_value (gfc_expr **expr)
     }
 
   m = gfc_match_expr (expr);
+
+  if (m == MATCH_YES
+      && gfc_expr_check_typed (*expr, gfc_current_ns, false) == FAILURE)
+    return MATCH_ERROR;
+
   if (m == MATCH_YES && (*expr)->expr_type == EXPR_FUNCTION)
     {
       if ((*expr)->value.function.actual
@@ -3743,6 +3753,8 @@ cleanup:
    can be matched.  Note that if nothing matches, MATCH_YES is
    returned (the null string was matched).  */
 
+bool in_prefix = false;
+
 match
 gfc_match_prefix (gfc_typespec *ts)
 {
@@ -3751,6 +3763,9 @@ gfc_match_prefix (gfc_typespec *ts)
   gfc_clear_attr (&current_attr);
   seen_type = 0;
 
+  gcc_assert (!in_prefix);
+  in_prefix = true;
+
 loop:
   if (!seen_type && ts != NULL
       && gfc_match_type_spec (ts, 0) == MATCH_YES
@@ -3764,7 +3779,7 @@ loop:
   if (gfc_match ("elemental% ") == MATCH_YES)
     {
       if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
-	return MATCH_ERROR;
+	goto error;
 
       goto loop;
     }
@@ -3772,7 +3787,7 @@ loop:
   if (gfc_match ("pure% ") == MATCH_YES)
     {
       if (gfc_add_pure (&current_attr, NULL) == FAILURE)
-	return MATCH_ERROR;
+	goto error;
 
       goto loop;
     }
@@ -3780,13 +3795,20 @@ loop:
   if (gfc_match ("recursive% ") == MATCH_YES)
     {
       if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
-	return MATCH_ERROR;
+	goto error;
 
       goto loop;
     }
 
   /* At this point, the next item is not a prefix.  */
+  gcc_assert (in_prefix);
+  in_prefix = false;
   return MATCH_YES;
+
+error:
+  gcc_assert (in_prefix);
+  in_prefix = false;
+  return MATCH_ERROR;
 }
 
 
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 1e92e14..941b5c5 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3266,3 +3266,78 @@ gfc_expr_set_symbols_referenced (gfc_expr *expr)
 {
   gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
 }
+
+
+/* Walk an expression tree and check each variable encountered for being typed.
+   If strict is not set, a top-level variable is tolerated untyped in -std=gnu
+   mode; this is for things in legacy-code like:
+
+     INTEGER :: arr(n), n
+
+   The namespace is needed for IMPLICIT typing.  */
+
+gfc_try
+gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
+{
+  gfc_try t;
+  gfc_actual_arglist* act;
+  gfc_constructor* c;
+
+  if (!e)
+    return SUCCESS;
+
+  /* FIXME:  Check indices for EXPR_VARIABLE / EXPR_SUBSTRING, too, to catch
+     things like len(arr(1:n)) as specification expression.  */
+
+  switch (e->expr_type)
+    {
+
+    case EXPR_NULL:
+    case EXPR_CONSTANT:
+    case EXPR_SUBSTRING:
+      break;
+
+    case EXPR_VARIABLE:
+      gcc_assert (e->symtree);
+      t = gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
+      if (t == FAILURE)
+	return t;
+      break;
+
+    case EXPR_FUNCTION:
+      for (act = e->value.function.actual; act; act = act->next)
+	{
+	  t = gfc_expr_check_typed (act->expr, ns, true);
+	  if (t == FAILURE)
+	    return t;
+	}
+      break;
+
+    case EXPR_OP:
+      t = gfc_expr_check_typed (e->value.op.op1, ns, true);
+      if (t == FAILURE)
+	return t;
+
+      t = gfc_expr_check_typed (e->value.op.op2, ns, true);
+      if (t == FAILURE)
+	return t;
+
+      break;
+
+    case EXPR_STRUCTURE:
+    case EXPR_ARRAY:
+      for (c = e->value.constructor; c; c = c->next)
+	{
+	  t = gfc_expr_check_typed (c->expr, ns, true);
+	  if (t == FAILURE)
+	    return t;
+	}
+      break;
+
+    default:
+      gcc_unreachable ();
+
+    }
+
+  return SUCCESS;
+}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index ccd2c03..a9a3633 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2245,6 +2245,10 @@ void copy_formal_args (gfc_symbol *dest, gfc_symbol *src);
 
 void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too  */
 
+/* FIXME:  Do this with parser-state instead of global variable.  */
+extern bool in_prefix;
+gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus);
+
 /* intrinsic.c */
 extern int gfc_init_expr;
 
@@ -2336,6 +2340,8 @@ bool gfc_traverse_expr (gfc_expr *, gfc_symbol *,
 			int);
 void gfc_expr_set_symbols_referenced (gfc_expr *);
 
+gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
+
 /* st.c */
 extern gfc_code new_st;
 
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 965e733..815dbc6 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -1576,7 +1576,7 @@ typedef struct
 st_state;
 
 static gfc_try
-verify_st_order (st_state *p, gfc_statement st)
+verify_st_order (st_state *p, gfc_statement st, bool silent)
 {
 
   switch (st)
@@ -1660,9 +1660,10 @@ verify_st_order (st_state *p, gfc_statement st)
   return SUCCESS;
 
 order:
-  gfc_error ("%s statement at %C cannot follow %s statement at %L",
-	     gfc_ascii_statement (st),
-	     gfc_ascii_statement (p->last_statement), &p->where);
+  if (!silent)
+    gfc_error ("%s statement at %C cannot follow %s statement at %L",
+	       gfc_ascii_statement (st),
+	       gfc_ascii_statement (p->last_statement), &p->where);
 
   return FAILURE;
 }
@@ -2169,6 +2170,26 @@ match_deferred_characteristics (gfc_typespec * ts)
 }
 
 
+/* Check specification-expressions in the function result of the currently
+   parsed block and ensure they are typed (give an IMPLICIT type if necessary).
+   For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
+   scope are not yet parsed so this has to be delayed up to parse_spec.  */
+
+static void
+check_function_result_typed (void)
+{
+  gfc_typespec* ts = &gfc_current_ns->proc_name->result->ts;
+
+  gcc_assert (gfc_current_state () == COMP_FUNCTION);
+  gcc_assert (ts->type != BT_UNKNOWN);
+
+  /* Check type-parameters, at the moment only CHARACTER lengths possible.  */
+  /* TODO:  Extend when KIND type parameters are implemented.  */
+  if (ts->type == BT_CHARACTER && ts->cl && ts->cl->length)
+    gfc_expr_check_typed (ts->cl->length, gfc_current_ns, true);
+}
+
+
 /* Parse a set of specification statements.  Returns the statement
    that doesn't fit.  */
 
@@ -2176,19 +2197,70 @@ static gfc_statement
 parse_spec (gfc_statement st)
 {
   st_state ss;
+  bool function_result_typed = false;
   bool bad_characteristic = false;
   gfc_typespec *ts;
 
-  verify_st_order (&ss, ST_NONE);
+  verify_st_order (&ss, ST_NONE, false);
   if (st == ST_NONE)
     st = next_statement ();
 
+  /* If we are not inside a function or don't have a result specified so far,
+     do nothing special about it.  */
+  if (gfc_current_state () != COMP_FUNCTION)
+    function_result_typed = true;
+  else
+    {
+      gfc_symbol* proc = gfc_current_ns->proc_name;
+      gcc_assert (proc);
+
+      if (proc->result->ts.type == BT_UNKNOWN)
+	function_result_typed = true;
+    }
+
 loop:
+  
+  /* If we find a statement that can not be followed by an IMPLICIT statement
+     (and thus we can expect to see none any further), type the function result
+     if it has not yet been typed.  Be careful not to give the END statement
+     to verify_st_order!  */
+  if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
+    {
+      bool verify_now = false;
+
+      if (st == ST_END_FUNCTION)
+	verify_now = true;
+      else
+	{
+	  st_state dummyss;
+	  verify_st_order (&dummyss, ST_NONE, false);
+	  verify_st_order (&dummyss, st, false);
+
+	  if (verify_st_order (&dummyss, ST_IMPLICIT, true) == FAILURE)
+	    verify_now = true;
+	}
+
+      if (verify_now)
+	{
+	  check_function_result_typed ();
+	  function_result_typed = true;
+	}
+    }
+
   switch (st)
     {
     case ST_NONE:
       unexpected_eof ();
 
+    case ST_IMPLICIT_NONE:
+    case ST_IMPLICIT:
+      if (!function_result_typed)
+	{
+	  check_function_result_typed ();
+	  function_result_typed = true;
+	}
+      goto declSt;
+
     case ST_FORMAT:
     case ST_ENTRY:
     case ST_DATA:	/* Not allowed in interfaces */
@@ -2199,14 +2271,13 @@ loop:
 
     case ST_USE:
     case ST_IMPORT:
-    case ST_IMPLICIT_NONE:
-    case ST_IMPLICIT:
     case ST_PARAMETER:
     case ST_PUBLIC:
     case ST_PRIVATE:
     case ST_DERIVED_DECL:
     case_decl:
-      if (verify_st_order (&ss, st) == FAILURE)
+declSt:
+      if (verify_st_order (&ss, st, false) == FAILURE)
 	{
 	  reject_statement ();
 	  st = next_statement ();
@@ -2295,7 +2366,7 @@ loop:
       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;
+	ts->type = BT_UNKNOWN;
     }
 
   return st;
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index d564dd7..1959822 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4230,3 +4230,36 @@ get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
   return new_symtree->n.sym;
 }
 
+
+/* Check that a symbol is already typed.  If strict is not set, an untyped
+   symbol is acceptable for non-standard-conforming mode.  */
+
+gfc_try
+gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
+			bool strict, locus where)
+{
+  gcc_assert (sym);
+
+  if (in_prefix)
+    return SUCCESS;
+
+  /* Check for the type and try to give it an implicit one.  */
+  if (sym->ts.type == BT_UNKNOWN
+      && gfc_set_default_type (sym, 0, ns) == FAILURE)
+    {
+      if (strict)
+	{
+	  gfc_error ("Symbol '%s' is used before it is typed at %L",
+		     sym->name, &where);
+	  return FAILURE;
+	}
+
+      if (gfc_notify_std (GFC_STD_GNU,
+			  "Extension: Symbol '%s' is used before"
+			  " it is typed at %L", sym->name, &where) == FAILURE)
+	return FAILURE;
+    }
+
+  /* Everything is ok.  */
+  return SUCCESS;
+}