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

17 files changed, 380 insertions, 23 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;
+}
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d4015a9..928a34b 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,18 @@
+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.
+
 2008-08-21  Manuel Lopez-Ibanez  <manu@gcc.gnu.org>
 
 	PR 30457
diff --git a/gcc/testsuite/gfortran.dg/argument_checking_7.f90 b/gcc/testsuite/gfortran.dg/argument_checking_7.f90
index 1c74fc5..0bf76cb 100644
--- a/gcc/testsuite/gfortran.dg/argument_checking_7.f90
+++ b/gcc/testsuite/gfortran.dg/argument_checking_7.f90
@@ -5,14 +5,14 @@ module cyclic
   implicit none
   contains
     function ouch(x,y) ! { dg-error "has no IMPLICIT type" }
-      implicit character(len(ouch)) (x) ! { dg-error "Conflict in attributes" }
-      implicit character(len(x)+1) (y)
-      implicit character(len(y)-1) (o)
+      implicit character(len(ouch)) (x) ! { dg-error "used before it is typed" }
+      implicit character(len(x)+1) (y) ! { dg-error "used before it is typed" }
+      implicit character(len(y)-1) (o) ! { dg-error "used before it is typed" }
       intent(in) x,y
-      character(len(y)-1) ouch
+      character(len(y)-1) ouch ! { dg-error "used before it is typed" }
       integer i
       do i = 1, len(ouch)
-        ouch(i:i) = achar(ieor(iachar(x(i:i)),iachar(y(i:i)))) ! { dg-error "Syntax error in argument list" }
+        ouch(i:i) = achar(ieor(iachar(x(i:i)),iachar(y(i:i)))) ! { dg-error "Unclassifiable statement" }
       end do
       end function ouch
 end module cyclic
diff --git a/gcc/testsuite/gfortran.dg/array_constructor_26.f03 b/gcc/testsuite/gfortran.dg/array_constructor_26.f03
index a226f6a..622bb51 100644
--- a/gcc/testsuite/gfortran.dg/array_constructor_26.f03
+++ b/gcc/testsuite/gfortran.dg/array_constructor_26.f03
@@ -1,4 +1,5 @@
 ! { dg-do compile }
+! { dg-options "-std=gnu" }
 
 ! PR fortran/36492
 ! Check for incorrect error message with -std=f2003.
@@ -10,8 +11,8 @@ MODULE WinData
   integer :: i
   TYPE TWindowData
     CHARACTER (MAX_FLD_HED, 1) :: DWFdHd(MAXFLD) = [(" ", i = 1, MAXFLD)]
-    ! { dg-error "no IMPLICIT type" "" { target *-*-* } 12 }
-    ! { dg-error "specification expression" "" { target *-*-* } 12 }
+    ! { dg-error "no IMPLICIT type" "" { target *-*-* } 13 }
+    ! { dg-error "specification expression" "" { target *-*-* } 13 }
   END TYPE TWindowData
 END MODULE WinData
 
diff --git a/gcc/testsuite/gfortran.dg/array_constructor_27.f03 b/gcc/testsuite/gfortran.dg/array_constructor_27.f03
index 6cd4d62..8068364 100644
--- a/gcc/testsuite/gfortran.dg/array_constructor_27.f03
+++ b/gcc/testsuite/gfortran.dg/array_constructor_27.f03
@@ -1,4 +1,5 @@
 ! { dg-do compile }
+! { dg-options "-std=gnu" }
 
 ! PR fortran/36492
 ! Check for incorrect error message with -std=f2003.
@@ -8,8 +9,8 @@ implicit none
 
 type t
   character (a) :: arr (1) = [ "a" ]
-  ! { dg-error "no IMPLICIT type" "" { target *-*-* } 10 }
-  ! { dg-error "specification expression" "" { target *-*-* } 10 }
+  ! { dg-error "no IMPLICIT type" "" { target *-*-* } 11 }
+  ! { dg-error "specification expression" "" { target *-*-* } 11 }
 end type t
 
 end
diff --git a/gcc/testsuite/gfortran.dg/blockdata_4.f90 b/gcc/testsuite/gfortran.dg/blockdata_4.f90
index 18836bc..5cf3d1f 100644
--- a/gcc/testsuite/gfortran.dg/blockdata_4.f90
+++ b/gcc/testsuite/gfortran.dg/blockdata_4.f90
@@ -1,4 +1,5 @@
 ! { dg-do compile }
+! { dg-options "-std=gnu" }
 ! PR33152 Initialization/declaration problems in block data
 ! Test case prepared by Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 blockdata bab
diff --git a/gcc/testsuite/gfortran.dg/bound_2.f90 b/gcc/testsuite/gfortran.dg/bound_2.f90
index 5c4026b..3b99a1f 100644
--- a/gcc/testsuite/gfortran.dg/bound_2.f90
+++ b/gcc/testsuite/gfortran.dg/bound_2.f90
@@ -1,4 +1,5 @@
 ! { dg-do run }
+! { dg-options "-std=gnu" }
 ! PR fortran/29391
 ! This file is here to check that LBOUND and UBOUND return correct values
 !
@@ -165,7 +166,7 @@
 contains
 
   subroutine sub1(a,n)
-    integer :: a(2:n+1,4:*), n
+    integer :: n, a(2:n+1,4:*)
 
     if (any([lbound(a,1), lbound(a,2)] /= [2, 4])) call abort
     if (any(lbound(a) /= [2, 4])) call abort
diff --git a/gcc/testsuite/gfortran.dg/result_in_spec_1.f90 b/gcc/testsuite/gfortran.dg/result_in_spec_1.f90
index 292bc3c..cbeb60f 100644
--- a/gcc/testsuite/gfortran.dg/result_in_spec_1.f90
+++ b/gcc/testsuite/gfortran.dg/result_in_spec_1.f90
@@ -35,8 +35,8 @@ program test
   if (any (myfunc (test2(1)) .ne. "ABC")) call abort ()
 contains
   function myfunc (ch) result (chr)
-    character(len(ch)) :: chr(4)
     character (*) :: ch(:)
+    character(len(ch)) :: chr(4)
     if (len (ch) .ne. 3) call abort ()
     if (any (ch .ne. "ABC")) call abort ()
     chr = test2 (1)
diff --git a/gcc/testsuite/gfortran.dg/used_before_typed_1.f90 b/gcc/testsuite/gfortran.dg/used_before_typed_1.f90
new file mode 100644
index 0000000..972a167
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/used_before_typed_1.f90
@@ -0,0 +1,40 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+
+! PR fortran/32095
+! PR fortran/34228
+! Check that standards-conforming mode rejects uses of variables that
+! are used before they are typed.
+
+SUBROUTINE test1 (n, arr, m, arr2, k, arr3, a) ! { dg-error "has no IMPLICIT" }
+  IMPLICIT NONE
+
+  INTEGER :: arr(n) ! { dg-error "used before it is typed" }
+  INTEGER :: n
+  INTEGER :: m, arr2(m) ! { dg-bogus "used before it is typed" }
+  INTEGER, DIMENSION(k) :: arr3 ! { dg-error "used before it is typed" }
+  INTEGER :: k
+  CHARACTER(len=LEN(a)) :: a ! { dg-error "'a' is used before it is typed" }
+
+  REAL(KIND=l) :: x ! { dg-error "has no IMPLICIT type" }
+  REAL(KIND=KIND(y)) :: y ! { dg-error "has no IMPLICIT type" }
+
+  DATA str/'abc'/ ! { dg-error "used before it is typed" }
+  CHARACTER(len=3) :: str, str2
+  DATA str2/'abc'/ ! { dg-bogus "used before it is typed" }
+END SUBROUTINE test1
+
+SUBROUTINE test2 (n, arr, m, arr2)
+  IMPLICIT INTEGER(a-z)
+
+  INTEGER :: arr(n)
+  REAL :: n ! { dg-error "already has basic type" }
+  INTEGER :: m, arr2(m) ! { dg-bogus "already has an IMPLICIT type" }
+END SUBROUTINE test2
+
+SUBROUTINE test3 (n, arr, m, arr2)
+  IMPLICIT REAL(a-z)
+
+  INTEGER :: arr(n) ! { dg-error "must be of INTEGER type" }
+  INTEGER :: m, arr2(m) ! { dg-bogus "must be of INTEGER type" }
+END SUBROUTINE test3
diff --git a/gcc/testsuite/gfortran.dg/used_before_typed_2.f90 b/gcc/testsuite/gfortran.dg/used_before_typed_2.f90
new file mode 100644
index 0000000..6f3031f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/used_before_typed_2.f90
@@ -0,0 +1,22 @@
+! { dg-do compile }
+! { dg-options "-std=gnu" }
+
+! PR fortran/32095
+! PR fortran/34228
+! This program used to segfault, check this is fixed.
+! Also check that -std=gnu behaves as expected.
+
+SUBROUTINE test1 (n, arr)
+  IMPLICIT NONE
+
+  INTEGER :: arr(n) ! { dg-bogus "used before it is typed" }
+  INTEGER :: n
+  CHARACTER(len=LEN(a)) :: a ! { dg-error "used before it is typed" }
+END SUBROUTINE test1
+
+SUBROUTINE test2 ()
+  IMPLICIT NONE
+
+  DATA str/'abc'/ ! { dg-bogus "used before it is typed" }
+  CHARACTER(len=3) :: str
+END SUBROUTINE test2
diff --git a/gcc/testsuite/gfortran.dg/used_before_typed_3.f90 b/gcc/testsuite/gfortran.dg/used_before_typed_3.f90
new file mode 100644
index 0000000..ab1b2a9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/used_before_typed_3.f90
@@ -0,0 +1,41 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+
+! PR fortran/32095
+! PR fortran/34228
+! Check for a special case when the return-type of a function is given outside
+! its "body" and contains symbols defined inside.
+
+MODULE testmod
+  IMPLICIT REAL(a-z)
+
+CONTAINS
+
+  CHARACTER(len=x) FUNCTION test1 (x) ! { dg-error "of INTEGER" }
+    IMPLICIT REAL(a-z)
+    INTEGER :: x ! { dg-error "already has basic type" }
+    test1 = "foobar"
+  END FUNCTION test1
+
+  CHARACTER(len=x) FUNCTION test2 (x) ! { dg-bogus "used before|of INTEGER" }
+    IMPLICIT INTEGER(a-z)
+    test2 = "foobar"
+  END FUNCTION test2
+
+END MODULE testmod
+  
+CHARACTER(len=i) FUNCTION test3 (i) ! { dg-bogus "used before|of INTEGER" }
+  ! i is IMPLICIT INTEGER by default
+  test3 = "foobar"
+END FUNCTION test3
+
+CHARACTER(len=g) FUNCTION test4 (g) ! { dg-error "of INTEGER" }
+  ! g is REAL, unless declared INTEGER.
+  test4 = "foobar"
+END FUNCTION test4
+
+! Test an empty function works, too.
+INTEGER FUNCTION test5 ()
+END FUNCTION test5
+
+! { dg-final { cleanup-modules "testmod" } }