+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.
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)
{
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;
}
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)
{
}
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
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)
{
gfc_clear_attr (¤t_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
if (gfc_match ("elemental% ") == MATCH_YES)
{
if (gfc_add_elemental (¤t_attr, NULL) == FAILURE)
- return MATCH_ERROR;
+ goto error;
goto loop;
}
if (gfc_match ("pure% ") == MATCH_YES)
{
if (gfc_add_pure (¤t_attr, NULL) == FAILURE)
- return MATCH_ERROR;
+ goto error;
goto loop;
}
if (gfc_match ("recursive% ") == MATCH_YES)
{
if (gfc_add_recursive (¤t_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;
}
{
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;
+}
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;
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;
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)
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;
}
}
+/* 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. */
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 */
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 ();
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;
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>
PR 30457
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
! { dg-do compile }
+! { dg-options "-std=gnu" }
! PR fortran/36492
! Check for incorrect error message with -std=f2003.
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
! { dg-do compile }
+! { dg-options "-std=gnu" }
! PR fortran/36492
! Check for incorrect error message with -std=f2003.
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
! { 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
! { dg-do run }
+! { dg-options "-std=gnu" }
! PR fortran/29391
! This file is here to check that LBOUND and UBOUND return correct values
!
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
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)
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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" } }
projects / thirdparty / gcc.git / commitdiff
