procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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
This commit is contained in:
Daniel Kraft 2008-08-22 09:13:25 +02:00 • committed by Daniel Kraft
parent 6b7387327a
commit f37e928ca4
17 changed files with 380 additions and 23 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

24
gcc/fortran/ChangeLog
View file

@ -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.

4
gcc/fortran/array.c
View file

@ -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;
}

28
gcc/fortran/decl.c
View file

@ -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;
}

75
gcc/fortran/expr.c
View file

@ -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;
}

6
gcc/fortran/gfortran.h
View file

@ -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;

89
gcc/fortran/parse.c
View file

@ -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;

33
gcc/fortran/symbol.c
View file

@ -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;
}

15
gcc/testsuite/ChangeLog
View file

@ -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

10
gcc/testsuite/gfortran.dg/argument_checking_7.f90
View file

@ -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

5
gcc/testsuite/gfortran.dg/array_constructor_26.f03
View file

@ -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

5
gcc/testsuite/gfortran.dg/array_constructor_27.f03
View file

@ -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

1
gcc/testsuite/gfortran.dg/blockdata_4.f90
View file

@ -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

3
gcc/testsuite/gfortran.dg/bound_2.f90
View file

@ -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

2
gcc/testsuite/gfortran.dg/result_in_spec_1.f90
View file

@ -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)

40
gcc/testsuite/gfortran.dg/used_before_typed_1.f90 Normal file
View file

@ -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

22
gcc/testsuite/gfortran.dg/used_before_typed_2.f90 Normal file
View file

@ -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

41
gcc/testsuite/gfortran.dg/used_before_typed_3.f90 Normal file
View file

@ -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" } }