Commit f37e928c by Daniel Kraft Committed by Daniel Kraft

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
parent 6b738732
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> 2008-08-21 Manuel Lopez-Ibanez <manu@gcc.gnu.org>
* f95-lang.c: Update all calls to pedwarn. * f95-lang.c: Update all calls to pedwarn.
......
...@@ -314,6 +314,8 @@ match_array_element_spec (gfc_array_spec *as) ...@@ -314,6 +314,8 @@ match_array_element_spec (gfc_array_spec *as)
gfc_error ("Expected expression in array specification at %C"); gfc_error ("Expected expression in array specification at %C");
if (m != MATCH_YES) if (m != MATCH_YES)
return AS_UNKNOWN; return AS_UNKNOWN;
if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
return AS_UNKNOWN;
if (gfc_match_char (':') == MATCH_NO) if (gfc_match_char (':') == MATCH_NO)
{ {
...@@ -332,6 +334,8 @@ match_array_element_spec (gfc_array_spec *as) ...@@ -332,6 +334,8 @@ match_array_element_spec (gfc_array_spec *as)
return AS_UNKNOWN; return AS_UNKNOWN;
if (m == MATCH_NO) if (m == MATCH_NO)
return AS_ASSUMED_SHAPE; return AS_ASSUMED_SHAPE;
if (gfc_expr_check_typed (*upper, gfc_current_ns, false) == FAILURE)
return AS_UNKNOWN;
return AS_EXPLICIT; return AS_EXPLICIT;
} }
......
...@@ -247,6 +247,11 @@ var_element (gfc_data_variable *new_var) ...@@ -247,6 +247,11 @@ var_element (gfc_data_variable *new_var)
sym = new_var->expr->symtree->n.sym; 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 if (!sym->attr.function && gfc_current_ns->parent
&& gfc_current_ns->parent == sym->ns) && gfc_current_ns->parent == sym->ns)
{ {
...@@ -598,6 +603,11 @@ char_len_param_value (gfc_expr **expr) ...@@ -598,6 +603,11 @@ char_len_param_value (gfc_expr **expr)
} }
m = gfc_match_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 (m == MATCH_YES && (*expr)->expr_type == EXPR_FUNCTION)
{ {
if ((*expr)->value.function.actual if ((*expr)->value.function.actual
...@@ -3743,6 +3753,8 @@ cleanup: ...@@ -3743,6 +3753,8 @@ cleanup:
can be matched. Note that if nothing matches, MATCH_YES is can be matched. Note that if nothing matches, MATCH_YES is
returned (the null string was matched). */ returned (the null string was matched). */
bool in_prefix = false;
match match
gfc_match_prefix (gfc_typespec *ts) gfc_match_prefix (gfc_typespec *ts)
{ {
...@@ -3751,6 +3763,9 @@ gfc_match_prefix (gfc_typespec *ts) ...@@ -3751,6 +3763,9 @@ gfc_match_prefix (gfc_typespec *ts)
gfc_clear_attr (&current_attr); gfc_clear_attr (&current_attr);
seen_type = 0; seen_type = 0;
gcc_assert (!in_prefix);
in_prefix = true;
loop: loop:
if (!seen_type && ts != NULL if (!seen_type && ts != NULL
&& gfc_match_type_spec (ts, 0) == MATCH_YES && gfc_match_type_spec (ts, 0) == MATCH_YES
...@@ -3764,7 +3779,7 @@ loop: ...@@ -3764,7 +3779,7 @@ loop:
if (gfc_match ("elemental% ") == MATCH_YES) if (gfc_match ("elemental% ") == MATCH_YES)
{ {
if (gfc_add_elemental (&current_attr, NULL) == FAILURE) if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
return MATCH_ERROR; goto error;
goto loop; goto loop;
} }
...@@ -3772,7 +3787,7 @@ loop: ...@@ -3772,7 +3787,7 @@ loop:
if (gfc_match ("pure% ") == MATCH_YES) if (gfc_match ("pure% ") == MATCH_YES)
{ {
if (gfc_add_pure (&current_attr, NULL) == FAILURE) if (gfc_add_pure (&current_attr, NULL) == FAILURE)
return MATCH_ERROR; goto error;
goto loop; goto loop;
} }
...@@ -3780,13 +3795,20 @@ loop: ...@@ -3780,13 +3795,20 @@ loop:
if (gfc_match ("recursive% ") == MATCH_YES) if (gfc_match ("recursive% ") == MATCH_YES)
{ {
if (gfc_add_recursive (&current_attr, NULL) == FAILURE) if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
return MATCH_ERROR; goto error;
goto loop; goto loop;
} }
/* At this point, the next item is not a prefix. */ /* At this point, the next item is not a prefix. */
gcc_assert (in_prefix);
in_prefix = false;
return MATCH_YES; return MATCH_YES;
error:
gcc_assert (in_prefix);
in_prefix = false;
return MATCH_ERROR;
} }
......
...@@ -3266,3 +3266,78 @@ gfc_expr_set_symbols_referenced (gfc_expr *expr) ...@@ -3266,3 +3266,78 @@ gfc_expr_set_symbols_referenced (gfc_expr *expr)
{ {
gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0); 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;
}
...@@ -2245,6 +2245,10 @@ void copy_formal_args (gfc_symbol *dest, gfc_symbol *src); ...@@ -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 */ 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 */ /* intrinsic.c */
extern int gfc_init_expr; extern int gfc_init_expr;
...@@ -2336,6 +2340,8 @@ bool gfc_traverse_expr (gfc_expr *, gfc_symbol *, ...@@ -2336,6 +2340,8 @@ bool gfc_traverse_expr (gfc_expr *, gfc_symbol *,
int); int);
void gfc_expr_set_symbols_referenced (gfc_expr *); void gfc_expr_set_symbols_referenced (gfc_expr *);
gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
/* st.c */ /* st.c */
extern gfc_code new_st; extern gfc_code new_st;
......
...@@ -1576,7 +1576,7 @@ typedef struct ...@@ -1576,7 +1576,7 @@ typedef struct
st_state; st_state;
static gfc_try 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) switch (st)
...@@ -1660,9 +1660,10 @@ verify_st_order (st_state *p, gfc_statement st) ...@@ -1660,9 +1660,10 @@ verify_st_order (st_state *p, gfc_statement st)
return SUCCESS; return SUCCESS;
order: order:
gfc_error ("%s statement at %C cannot follow %s statement at %L", if (!silent)
gfc_ascii_statement (st), gfc_error ("%s statement at %C cannot follow %s statement at %L",
gfc_ascii_statement (p->last_statement), &p->where); gfc_ascii_statement (st),
gfc_ascii_statement (p->last_statement), &p->where);
return FAILURE; return FAILURE;
} }
...@@ -2169,6 +2170,26 @@ match_deferred_characteristics (gfc_typespec * ts) ...@@ -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 /* Parse a set of specification statements. Returns the statement
that doesn't fit. */ that doesn't fit. */
...@@ -2176,19 +2197,70 @@ static gfc_statement ...@@ -2176,19 +2197,70 @@ static gfc_statement
parse_spec (gfc_statement st) parse_spec (gfc_statement st)
{ {
st_state ss; st_state ss;
bool function_result_typed = false;
bool bad_characteristic = false; bool bad_characteristic = false;
gfc_typespec *ts; gfc_typespec *ts;
verify_st_order (&ss, ST_NONE); verify_st_order (&ss, ST_NONE, false);
if (st == ST_NONE) if (st == ST_NONE)
st = next_statement (); 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: 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) switch (st)
{ {
case ST_NONE: case ST_NONE:
unexpected_eof (); 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_FORMAT:
case ST_ENTRY: case ST_ENTRY:
case ST_DATA: /* Not allowed in interfaces */ case ST_DATA: /* Not allowed in interfaces */
...@@ -2199,14 +2271,13 @@ loop: ...@@ -2199,14 +2271,13 @@ loop:
case ST_USE: case ST_USE:
case ST_IMPORT: case ST_IMPORT:
case ST_IMPLICIT_NONE:
case ST_IMPLICIT:
case ST_PARAMETER: case ST_PARAMETER:
case ST_PUBLIC: case ST_PUBLIC:
case ST_PRIVATE: case ST_PRIVATE:
case ST_DERIVED_DECL: case ST_DERIVED_DECL:
case_decl: case_decl:
if (verify_st_order (&ss, st) == FAILURE) declSt:
if (verify_st_order (&ss, st, false) == FAILURE)
{ {
reject_statement (); reject_statement ();
st = next_statement (); st = next_statement ();
...@@ -2295,7 +2366,7 @@ loop: ...@@ -2295,7 +2366,7 @@ loop:
gfc_current_block ()->ts.kind = 0; gfc_current_block ()->ts.kind = 0;
/* Keep the derived type; if it's bad, it will be discovered later. */ /* Keep the derived type; if it's bad, it will be discovered later. */
if (!(ts->type == BT_DERIVED && ts->derived)) if (!(ts->type == BT_DERIVED && ts->derived))
ts->type = BT_UNKNOWN; ts->type = BT_UNKNOWN;
} }
return st; return st;
......
...@@ -4230,3 +4230,36 @@ get_iso_c_sym (gfc_symbol *old_sym, char *new_name, ...@@ -4230,3 +4230,36 @@ get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
return new_symtree->n.sym; 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;
}
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> 2008-08-21 Manuel Lopez-Ibanez <manu@gcc.gnu.org>
PR 30457 PR 30457
......
...@@ -5,14 +5,14 @@ module cyclic ...@@ -5,14 +5,14 @@ module cyclic
implicit none implicit none
contains contains
function ouch(x,y) ! { dg-error "has no IMPLICIT type" } function ouch(x,y) ! { dg-error "has no IMPLICIT type" }
implicit character(len(ouch)) (x) ! { dg-error "Conflict in attributes" } implicit character(len(ouch)) (x) ! { dg-error "used before it is typed" }
implicit character(len(x)+1) (y) implicit character(len(x)+1) (y) ! { dg-error "used before it is typed" }
implicit character(len(y)-1) (o) implicit character(len(y)-1) (o) ! { dg-error "used before it is typed" }
intent(in) x,y intent(in) x,y
character(len(y)-1) ouch character(len(y)-1) ouch ! { dg-error "used before it is typed" }
integer i integer i
do i = 1, len(ouch) 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 do
end function ouch end function ouch
end module cyclic end module cyclic
! { dg-do compile } ! { dg-do compile }
! { dg-options "-std=gnu" }
! PR fortran/36492 ! PR fortran/36492
! Check for incorrect error message with -std=f2003. ! Check for incorrect error message with -std=f2003.
...@@ -10,8 +11,8 @@ MODULE WinData ...@@ -10,8 +11,8 @@ MODULE WinData
integer :: i integer :: i
TYPE TWindowData TYPE TWindowData
CHARACTER (MAX_FLD_HED, 1) :: DWFdHd(MAXFLD) = [(" ", i = 1, MAXFLD)] CHARACTER (MAX_FLD_HED, 1) :: DWFdHd(MAXFLD) = [(" ", i = 1, MAXFLD)]
! { dg-error "no IMPLICIT type" "" { target *-*-* } 12 } ! { dg-error "no IMPLICIT type" "" { target *-*-* } 13 }
! { dg-error "specification expression" "" { target *-*-* } 12 } ! { dg-error "specification expression" "" { target *-*-* } 13 }
END TYPE TWindowData END TYPE TWindowData
END MODULE WinData END MODULE WinData
......
! { dg-do compile } ! { dg-do compile }
! { dg-options "-std=gnu" }
! PR fortran/36492 ! PR fortran/36492
! Check for incorrect error message with -std=f2003. ! Check for incorrect error message with -std=f2003.
...@@ -8,8 +9,8 @@ implicit none ...@@ -8,8 +9,8 @@ implicit none
type t type t
character (a) :: arr (1) = [ "a" ] character (a) :: arr (1) = [ "a" ]
! { dg-error "no IMPLICIT type" "" { target *-*-* } 10 } ! { dg-error "no IMPLICIT type" "" { target *-*-* } 11 }
! { dg-error "specification expression" "" { target *-*-* } 10 } ! { dg-error "specification expression" "" { target *-*-* } 11 }
end type t end type t
end end
! { dg-do compile } ! { dg-do compile }
! { dg-options "-std=gnu" }
! PR33152 Initialization/declaration problems in block data ! PR33152 Initialization/declaration problems in block data
! Test case prepared by Jerry DeLisle <jvdelisle@gcc.gnu.org> ! Test case prepared by Jerry DeLisle <jvdelisle@gcc.gnu.org>
blockdata bab blockdata bab
......
! { dg-do run } ! { dg-do run }
! { dg-options "-std=gnu" }
! PR fortran/29391 ! PR fortran/29391
! This file is here to check that LBOUND and UBOUND return correct values ! This file is here to check that LBOUND and UBOUND return correct values
! !
...@@ -165,7 +166,7 @@ ...@@ -165,7 +166,7 @@
contains contains
subroutine sub1(a,n) 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,1), lbound(a,2)] /= [2, 4])) call abort
if (any(lbound(a) /= [2, 4])) call abort if (any(lbound(a) /= [2, 4])) call abort
......
...@@ -35,8 +35,8 @@ program test ...@@ -35,8 +35,8 @@ program test
if (any (myfunc (test2(1)) .ne. "ABC")) call abort () if (any (myfunc (test2(1)) .ne. "ABC")) call abort ()
contains contains
function myfunc (ch) result (chr) function myfunc (ch) result (chr)
character(len(ch)) :: chr(4)
character (*) :: ch(:) character (*) :: ch(:)
character(len(ch)) :: chr(4)
if (len (ch) .ne. 3) call abort () if (len (ch) .ne. 3) call abort ()
if (any (ch .ne. "ABC")) call abort () if (any (ch .ne. "ABC")) call abort ()
chr = test2 (1) chr = test2 (1)
......
! { 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
! { 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
! { 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" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment