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
This commit is contained in:
Daniel Kraft
Daniel Kraft
parent
6b7387327a
commit
f37e928ca4
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 (¤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
|
||||
|
|
@ -3764,7 +3779,7 @@ loop:
|
|||
if (gfc_match ("elemental% ") == MATCH_YES)
|
||||
{
|
||||
if (gfc_add_elemental (¤t_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 (¤t_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 (¤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;
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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,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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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" } }
|
||||
Loading…
Reference in New Issue