OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/38936 ([F03] ASSOCIATE construct / improved SELECT TYPE (a=>expr)) 

2010-09-23  Daniel Kraft  <d@domob.eu>

	PR fortran/38936
	PR fortran/44044
	PR fortran/45474
	* gfortran.h (gfc_check_vardef_context): New method.
	(struct symbol_attribute): New flag `select_type_temporary'.
	* primary.c (gfc_variable_attr): Clarify initialization of ref.
	(match_variable): Remove PROTECTED check and assignment check
	for PARAMETERs (this is now done later).
	* match.c (gfc_match_iterator): Remove INTENT(IN) check.
	(gfc_match_associate): Defer initialization of newAssoc->variable.
	(gfc_match_nullify): Remove PURE definability check.
	(select_type_set_tmp): Set new `select_type_temporary' flag.
	* expr.c (gfc_check_assign): Remove INTENT(IN) check here.
	(gfc_check_pointer_assign): Ditto (and other checks removed).
	(gfc_check_vardef_context): New method.
	* interface.c (compare_parameter_protected): Removed.
	(compare_actual_formal): Use `gfc_check_vardef_context' for checks
	related to INTENT([IN]OUT) arguments.
	* intrinsic.c (check_arglist): Check INTENT for intrinsics.
	* resolve.c (gfc_resolve_iterator): Use `gfc_check_vardef_context'.
	(remove_last_array_ref): New method.
	(resolve_deallocate_expr), (resolve_allocate_expr): Ditto.
	(resolve_allocate_deallocate): Ditto (for STAT and ERRMSG).
	(resolve_assoc_var): Remove checks for definability here.
	(resolve_select_type): Handle resolving of code->block here.
	(resolve_ordinary_assign): Remove PURE check.
	(resolve_code): Do not resolve code->blocks for SELECT TYPE here.
	Use `gfc_check_vardef_context' for assignments and pointer-assignments.

2010-09-23  Daniel Kraft  <d@domob.eu>

	PR fortran/38936
	PR fortran/44044
	PR fortran/45474
	* gfortran.dg/intrinsic_intent_1.f03: New test.
	* gfortran.dg/select_type_17.f03: New test.
	* gfortran.dg/associate_5.f03: More definability tests.
	* gfortran.dg/enum_2.f90: Check definability.
	* gfortran.dg/allocatable_dummy_2.f90: Change expected error message.
	* gfortran.dg/allocate_alloc_opt_2.f90: Ditto.
	* gfortran.dg/char_expr_2.f90: Ditto.
	* gfortran.dg/deallocate_alloc_opt_2.f90: Ditto.
	* gfortran.dg/enum_5.f90: Ditto.
	* gfortran.dg/equiv_constraint_8.f90: Ditto.
	* gfortran.dg/impure_assignment_2.f90: Ditto.
	* gfortran.dg/impure_assignment_3.f90: Ditto.
	* gfortran.dg/intent_out_1.f90: Ditto.
	* gfortran.dg/intent_out_3.f90: Ditto.
	* gfortran.dg/pointer_assign_7.f90: Ditto.
	* gfortran.dg/pointer_intent_3.f90: Ditto.
	* gfortran.dg/pr19936_1.f90: Ditto.
	* gfortran.dg/proc_ptr_comp_3.f90: Ditto.
	* gfortran.dg/simpleif_2.f90: Ditto.
	* gfortran.dg/protected_5.f90: Ditto.
	* gfortran.dg/protected_4.f90: Ditto and remove invalid error check.
	* gfortran.dg/protected_6.f90: Ditto.
	* gfortran.dg/protected_7.f90: Ditto.

From-SVN: r164550
This commit is contained in:
Daniel Kraft 2010-09-23 10:37:54 +02:00 committed by Daniel Kraft
parent 42d9f9dd0f
commit 8c91ab34b5
32 changed files with 521 additions and 282 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
gcc/fortran/ChangeLog
View File

@ -1,3 +1,34 @@
2010-09-23 Daniel Kraft <d@domob.eu>
PR fortran/38936
PR fortran/44044
PR fortran/45474
* gfortran.h (gfc_check_vardef_context): New method.
(struct symbol_attribute): New flag `select_type_temporary'.
* primary.c (gfc_variable_attr): Clarify initialization of ref.
(match_variable): Remove PROTECTED check and assignment check
for PARAMETERs (this is now done later).
* match.c (gfc_match_iterator): Remove INTENT(IN) check.
(gfc_match_associate): Defer initialization of newAssoc->variable.
(gfc_match_nullify): Remove PURE definability check.
(select_type_set_tmp): Set new `select_type_temporary' flag.
* expr.c (gfc_check_assign): Remove INTENT(IN) check here.
(gfc_check_pointer_assign): Ditto (and other checks removed).
(gfc_check_vardef_context): New method.
* interface.c (compare_parameter_protected): Removed.
(compare_actual_formal): Use `gfc_check_vardef_context' for checks
related to INTENT([IN]OUT) arguments.
* intrinsic.c (check_arglist): Check INTENT for intrinsics.
* resolve.c (gfc_resolve_iterator): Use `gfc_check_vardef_context'.
(remove_last_array_ref): New method.
(resolve_deallocate_expr), (resolve_allocate_expr): Ditto.
(resolve_allocate_deallocate): Ditto (for STAT and ERRMSG).
(resolve_assoc_var): Remove checks for definability here.
(resolve_select_type): Handle resolving of code->block here.
(resolve_ordinary_assign): Remove PURE check.
(resolve_code): Do not resolve code->blocks for SELECT TYPE here.
Use `gfc_check_vardef_context' for assignments and pointer-assignments.
2010-08-22 Ralf Wildenhues <Ralf.Wildenhues@gmx.de>
* gfortran.texi (Argument list functions): Allow URL to wrap.

233
gcc/fortran/expr.c
View File

@ -3043,10 +3043,8 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
sym = lvalue->symtree->n.sym;
/* Check INTENT(IN), unless the object itself is the component or
sub-component of a pointer. */
/* See if this is the component or subcomponent of a pointer. */
has_pointer = sym->attr.pointer;
for (ref = lvalue->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
{
@ -3054,13 +3052,6 @@ gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
break;
}
if (!has_pointer && sym->attr.intent == INTENT_IN)
{
gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
sym->name, &lvalue->where);
return FAILURE;
}
/* 12.5.2.2, Note 12.26: The result variable is very similar to any other
variable local to a function subprogram. Its existence begins when
execution of the function is initiated and ends when execution of the
@ -3239,7 +3230,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
symbol_attribute attr;
gfc_ref *ref;
bool is_pure, rank_remap;
int pointer, check_intent_in, proc_pointer;
int proc_pointer;
if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
&& !lvalue->symtree->n.sym->attr.proc_pointer)
@ -3259,24 +3250,13 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
return FAILURE;
}
/* Check INTENT(IN), unless the object itself is the component or
sub-component of a pointer. */
check_intent_in = 1;
pointer = lvalue->symtree->n.sym->attr.pointer;
proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
rank_remap = false;
for (ref = lvalue->ref; ref; ref = ref->next)
{
if (pointer)
check_intent_in = 0;
if (ref->type == REF_COMPONENT)
{
pointer = ref->u.c.component->attr.pointer;
proc_pointer = ref->u.c.component->attr.proc_pointer;
}
proc_pointer = ref->u.c.component->attr.proc_pointer;
if (ref->type == REF_ARRAY && ref->next == NULL)
{
@ -3332,30 +3312,8 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
}
}
if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
lvalue->symtree->n.sym->name, &lvalue->where);
return FAILURE;
}
if (!pointer && !proc_pointer
&& !(lvalue->ts.type == BT_CLASS
&& CLASS_DATA (lvalue)->attr.class_pointer))
{
gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
return FAILURE;
}
is_pure = gfc_pure (NULL);
if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
&& lvalue->symtree->n.sym->value != rvalue)
{
gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
return FAILURE;
}
/* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
kind, etc for lvalue and rvalue must match, and rvalue must be a
pure variable if we're in a pure function. */
@ -4338,3 +4296,188 @@ gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
return result;
}
/* Check if an expression may appear in a variable definition context
(F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
This is called from the various places when resolving
the pieces that make up such a context.
Optionally, a possible error message can be suppressed if context is NULL
and just the return status (SUCCESS / FAILURE) be requested. */
gfc_try
gfc_check_vardef_context (gfc_expr* e, bool pointer, const char* context)
{
gfc_symbol* sym;
bool is_pointer;
bool check_intentin;
bool ptr_component;
symbol_attribute attr;
gfc_ref* ref;
if (e->expr_type != EXPR_VARIABLE)
{
if (context)
gfc_error ("Non-variable expression in variable definition context (%s)"
" at %L", context, &e->where);
return FAILURE;
}
gcc_assert (e->symtree);
sym = e->symtree->n.sym;
if (!pointer && sym->attr.flavor == FL_PARAMETER)
{
if (context)
gfc_error ("Named constant '%s' in variable definition context (%s)"
" at %L", sym->name, context, &e->where);
return FAILURE;
}
if (!pointer && sym->attr.flavor != FL_VARIABLE
&& !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result)
&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
{
if (context)
gfc_error ("'%s' in variable definition context (%s) at %L is not"
" a variable", sym->name, context, &e->where);
return FAILURE;
}
/* Find out whether the expr is a pointer; this also means following
component references to the last one. */
attr = gfc_expr_attr (e);
is_pointer = (attr.pointer || attr.proc_pointer);
if (pointer && !is_pointer)
{
if (context)
gfc_error ("Non-POINTER in pointer association context (%s)"
" at %L", context, &e->where);
return FAILURE;
}
/* INTENT(IN) dummy argument. Check this, unless the object itself is
the component of sub-component of a pointer. Obviously,
procedure pointers are of no interest here. */
check_intentin = true;
ptr_component = sym->attr.pointer;
for (ref = e->ref; ref && check_intentin; ref = ref->next)
{
if (ptr_component && ref->type == REF_COMPONENT)
check_intentin = false;
if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
ptr_component = true;
}
if (check_intentin && sym->attr.intent == INTENT_IN)
{
if (pointer && is_pointer)
{
if (context)
gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
" association context (%s) at %L",
sym->name, context, &e->where);
return FAILURE;
}
if (!pointer && !is_pointer)
{
if (context)
gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
" definition context (%s) at %L",
sym->name, context, &e->where);
return FAILURE;
}
}
/* PROTECTED and use-associated. */
if (sym->attr.is_protected && sym->attr.use_assoc)
{
if (pointer && is_pointer)
{
if (context)
gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
" pointer association context (%s) at %L",
sym->name, context, &e->where);
return FAILURE;
}
if (!pointer && !is_pointer)
{
if (context)
gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
" variable definition context (%s) at %L",
sym->name, context, &e->where);
return FAILURE;
}
}
/* Variable not assignable from a PURE procedure but appears in
variable definition context. */
if (!pointer && gfc_pure (NULL) && gfc_impure_variable (sym))
{
if (context)
gfc_error ("Variable '%s' can not appear in a variable definition"
" context (%s) at %L in PURE procedure",
sym->name, context, &e->where);
return FAILURE;
}
/* Check variable definition context for associate-names. */
if (!pointer && sym->assoc)
{
const char* name;
gfc_association_list* assoc;
gcc_assert (sym->assoc->target);
/* If this is a SELECT TYPE temporary (the association is used internally
for SELECT TYPE), silently go over to the target. */
if (sym->attr.select_type_temporary)
{
gfc_expr* t = sym->assoc->target;
gcc_assert (t->expr_type == EXPR_VARIABLE);
name = t->symtree->name;
if (t->symtree->n.sym->assoc)
assoc = t->symtree->n.sym->assoc;
else
assoc = sym->assoc;
}
else
{
name = sym->name;
assoc = sym->assoc;
}
gcc_assert (name && assoc);
/* Is association to a valid variable? */
if (!assoc->variable)
{
if (context)
{
if (assoc->target->expr_type == EXPR_VARIABLE)
gfc_error ("'%s' at %L associated to vector-indexed target can"
" not be used in a variable definition context (%s)",
name, &e->where, context);
else
gfc_error ("'%s' at %L associated to expression can"
" not be used in a variable definition context (%s)",
name, &e->where, context);
}
return FAILURE;
}
/* Target must be allowed to appear in a variable definition context. */
if (gfc_check_vardef_context (assoc->target, pointer, NULL) == FAILURE)
{
if (context)
gfc_error ("Associate-name '%s' can not appear in a variable"
" definition context (%s) at %L because its target"
" at %L can not, either",
name, context, &e->where,
&assoc->target->where);
return FAILURE;
}
}
return SUCCESS;
}

4
gcc/fortran/gfortran.h
View File

@ -784,6 +784,9 @@ typedef struct
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
private_comp:1, zero_comp:1, coarray_comp:1;
/* This is a temporary selector for SELECT TYPE. */
unsigned select_type_temporary:1;
/* Attributes set by compiler extensions (!GCC$ ATTRIBUTES). */
unsigned ext_attr:EXT_ATTR_NUM;
@ -2726,6 +2729,7 @@ bool gfc_has_ultimate_allocatable (gfc_expr *);
bool gfc_has_ultimate_pointer (gfc_expr *);
gfc_expr* gfc_build_intrinsic_call (const char*, locus, unsigned, ...);
gfc_try gfc_check_vardef_context (gfc_expr*, bool, const char*);
/* st.c */

61
gcc/fortran/interface.c
View File

@ -1655,36 +1655,6 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
}
/* Given a symbol of a formal argument list and an expression, see if
the two are compatible as arguments. Returns nonzero if
compatible, zero if not compatible. */
static int
compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
{
if (actual->expr_type != EXPR_VARIABLE)
return 1;
if (!actual->symtree->n.sym->attr.is_protected)
return 1;
if (!actual->symtree->n.sym->attr.use_assoc)
return 1;
if (formal->attr.intent == INTENT_IN
|| formal->attr.intent == INTENT_UNKNOWN)
return 1;
if (!actual->symtree->n.sym->attr.pointer)
return 0;
if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
return 0;
return 1;
}
/* Returns the storage size of a symbol (formal argument) or
zero if it cannot be determined. */
@ -2205,27 +2175,20 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
}
/* Check intent = OUT/INOUT for definable actual argument. */
if ((a->expr->expr_type != EXPR_VARIABLE
|| (a->expr->symtree->n.sym->attr.flavor != FL_VARIABLE
&& a->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE))
&& (f->sym->attr.intent == INTENT_OUT
|| f->sym->attr.intent == INTENT_INOUT))
if ((f->sym->attr.intent == INTENT_OUT
|| f->sym->attr.intent == INTENT_INOUT))
{
if (where)
gfc_error ("Actual argument at %L must be definable as "
"the dummy argument '%s' is INTENT = OUT/INOUT",
&a->expr->where, f->sym->name);
return 0;
}
const char* context = (where
? _("actual argument to INTENT = OUT/INOUT")
: NULL);
if (!compare_parameter_protected(f->sym, a->expr))
{
if (where)
gfc_error ("Actual argument at %L is use-associated with "
"PROTECTED attribute and dummy argument '%s' is "
"INTENT = OUT/INOUT",
&a->expr->where,f->sym->name);
return 0;
if (f->sym->attr.pointer
&& gfc_check_vardef_context (a->expr, true, context)
== FAILURE)
return 0;
if (gfc_check_vardef_context (a->expr, false, context)
== FAILURE)
return 0;
}
if ((f->sym->attr.intent == INTENT_OUT

13
gcc/fortran/intrinsic.c
View File

@ -3585,6 +3585,19 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
gfc_typename (&actual->expr->ts));
return FAILURE;
}
/* If the formal argument is INTENT([IN]OUT), check for definability. */
if (formal->intent == INTENT_INOUT || formal->intent == INTENT_OUT)
{
const char* context = (error_flag
? _("actual argument to INTENT = OUT/INOUT")
: NULL);
/* No pointer arguments for intrinsics. */
if (gfc_check_vardef_context (actual->expr, false, context)
== FAILURE)
return FAILURE;
}
}
return SUCCESS;

18
gcc/fortran/match.c
View File

@ -978,13 +978,6 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag)
goto cleanup;
}
if (var->symtree->n.sym->attr.intent == INTENT_IN)
{
gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
var->symtree->n.sym->name);
goto cleanup;
}
gfc_match_char ('=');
var->symtree->n.sym->attr.implied_index = 1;
@ -1847,9 +1840,7 @@ gfc_match_associate (void)
/* The `variable' field is left blank for now; because the target is not
yet resolved, we can't use gfc_has_vector_subscript to determine it
for now. Instead, if the symbol is matched as variable, this field
is set -- and during resolution we check that. */
newAssoc->variable = 0;
for now. This is set during resolution. */
/* Put it into the list. */
newAssoc->next = new_st.ext.block.assoc;
@ -3166,12 +3157,6 @@ gfc_match_nullify (void)
if (gfc_check_do_variable (p->symtree))
goto cleanup;
if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
{
gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
goto cleanup;
}
/* build ' => NULL() '. */
e = gfc_get_null_expr (&gfc_current_locus);
@ -4523,6 +4508,7 @@ select_type_set_tmp (gfc_typespec *ts)
&tmp->n.sym->as, false);
tmp->n.sym->attr.class_ok = 1;
}
tmp->n.sym->attr.select_type_temporary = 1;
/* Add an association for it, so the rest of the parser knows it is
an associate-name. The target will be set during resolution. */

35
gcc/fortran/primary.c
View File

@ -2007,7 +2007,6 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
ref = expr->ref;
sym = expr->symtree->n.sym;
attr = sym->attr;
@ -2031,7 +2030,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
if (ts != NULL && expr->ts.type == BT_UNKNOWN)
*ts = sym->ts;
for (; ref; ref = ref->next)
for (ref = expr->ref; ref; ref = ref->next)
switch (ref->type)
{
case REF_ARRAY:
@ -2986,13 +2985,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
switch (sym->attr.flavor)
{
case FL_VARIABLE:
if (sym->attr.is_protected && sym->attr.use_assoc)
{
gfc_error ("Assigning to PROTECTED variable at %C");
return MATCH_ERROR;
}
if (sym->assoc)
sym->assoc->variable = 1;
/* Everything is alright. */
break;
case FL_UNKNOWN:
@ -3024,22 +3017,24 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
case FL_PARAMETER:
if (equiv_flag)
gfc_error ("Named constant at %C in an EQUIVALENCE");
else
gfc_error ("Cannot assign to a named constant at %C");
return MATCH_ERROR;
{
gfc_error ("Named constant at %C in an EQUIVALENCE");
return MATCH_ERROR;
}
/* Otherwise this is checked for and an error given in the
variable definition context checks. */
break;
case FL_PROCEDURE:
/* Check for a nonrecursive function result variable. */
if (sym->attr.function
&& !sym->attr.external
&& sym->result == sym
&& (gfc_is_function_return_value (sym, gfc_current_ns)
|| (sym->attr.entry
&& sym->ns == gfc_current_ns)
|| (sym->attr.entry
&& sym->ns == gfc_current_ns->parent)))
&& !sym->attr.external
&& sym->result == sym
&& (gfc_is_function_return_value (sym, gfc_current_ns)
|| (sym->attr.entry
&& sym->ns == gfc_current_ns)
|| (sym->attr.entry
&& sym->ns == gfc_current_ns->parent)))
{
/* If a function result is a derived type, then the derived
type may still have to be resolved. */

181
gcc/fortran/resolve.c
View File

@ -2859,8 +2859,6 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
/* Resolve a function call, which means resolving the arguments, then figuring
out which entity the name refers to. */
/* TODO: Check procedure arguments so that an INTENT(IN) isn't passed
to INTENT(OUT) or INTENT(INOUT). */
static gfc_try
resolve_function (gfc_expr *expr)
@ -6131,12 +6129,9 @@ gfc_resolve_iterator (gfc_iterator *iter, bool real_ok)
== FAILURE)
return FAILURE;
if (gfc_pure (NULL) && gfc_impure_variable (iter->var->symtree->n.sym))
{
gfc_error ("Cannot assign to loop variable in PURE procedure at %L",
&iter->var->where);
return FAILURE;
}
if (gfc_check_vardef_context (iter->var, false, _("iterator variable"))
== FAILURE)
return FAILURE;
if (gfc_resolve_iterator_expr (iter->start, real_ok,
"Start expression in DO loop") == FAILURE)
@ -6331,14 +6326,11 @@ static gfc_try
resolve_deallocate_expr (gfc_expr *e)
{
symbol_attribute attr;
int allocatable, pointer, check_intent_in;
int allocatable, pointer;
gfc_ref *ref;
gfc_symbol *sym;
gfc_component *c;
/* Check INTENT(IN), unless the object is a sub-component of a pointer. */
check_intent_in = 1;
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
@ -6359,9 +6351,6 @@ resolve_deallocate_expr (gfc_expr *e)
}
for (ref = e->ref; ref; ref = ref->next)
{
if (pointer)
check_intent_in = 0;
switch (ref->type)
{
case REF_ARRAY:
@ -6399,12 +6388,11 @@ resolve_deallocate_expr (gfc_expr *e)
return FAILURE;
}
if (check_intent_in && sym->attr.intent == INTENT_IN)
{
gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
sym->name, &e->where);
return FAILURE;
}
if (pointer
&& gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE)
return FAILURE;
if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE)
return FAILURE;
if (e->ts.type == BT_CLASS)
{
@ -6464,6 +6452,31 @@ gfc_expr_to_initialize (gfc_expr *e)
}
/* If the last ref of an expression is an array ref, return a copy of the
expression with that one removed. Otherwise, a copy of the original
expression. This is used for allocate-expressions and pointer assignment
LHS, where there may be an array specification that needs to be stripped
off when using gfc_check_vardef_context. */
static gfc_expr*
remove_last_array_ref (gfc_expr* e)
{
gfc_expr* e2;
gfc_ref** r;
e2 = gfc_copy_expr (e);
for (r = &e2->ref; *r; r = &(*r)->next)
if ((*r)->type == REF_ARRAY && !(*r)->next)
{
gfc_free_ref_list (*r);
*r = NULL;
break;
}
return e2;
}
/* Used in resolve_allocate_expr to check that a allocation-object and
a source-expr are conformable. This does not catch all possible
cases; in particular a runtime checking is needed. */
@ -6526,17 +6539,16 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
static gfc_try
resolve_allocate_expr (gfc_expr *e, gfc_code *code)
{
int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
int i, pointer, allocatable, dimension, is_abstract;
int codimension;
symbol_attribute attr;
gfc_ref *ref, *ref2;
gfc_expr *e2;
gfc_array_ref *ar;
gfc_symbol *sym = NULL;
gfc_alloc *a;
gfc_component *c;
/* Check INTENT(IN), unless the object is a sub-component of a pointer. */
check_intent_in = 1;
gfc_try t;
/* Mark the ultimost array component as being in allocate to allow DIMEN_STAR
checking of coarrays. */
@ -6588,9 +6600,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
{
if (pointer)
check_intent_in = 0;
switch (ref->type)
{
case REF_ARRAY:
@ -6677,12 +6686,18 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
goto failure;
}
if (check_intent_in && sym->attr.intent == INTENT_IN)
{
gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
sym->name, &e->where);
goto failure;
}
/* In the variable definition context checks, gfc_expr_attr is used
on the expression. This is fooled by the array specification
present in e, thus we have to eliminate that one temporarily. */
e2 = remove_last_array_ref (e);
t = SUCCESS;
if (t == SUCCESS && pointer)
t = gfc_check_vardef_context (e2, true, _("ALLOCATE object"));
if (t == SUCCESS)
t = gfc_check_vardef_context (e2, false, _("ALLOCATE object"));
gfc_free_expr (e2);
if (t == FAILURE)
goto failure;
if (!code->expr3)
{
@ -6733,9 +6748,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
if (pointer || (dimension == 0 && codimension == 0))
goto success;
/* Make sure the next-to-last reference node is an array specification. */
/* Make sure the last reference node is an array specifiction. */
if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
|| (dimension && ref2->u.ar.dimen == 0))
{
gfc_error ("Array specification required in ALLOCATE statement "
@ -6846,20 +6861,13 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
gfc_expr *stat, *errmsg, *pe, *qe;
gfc_alloc *a, *p, *q;
stat = code->expr1 ? code->expr1 : NULL;
errmsg = code->expr2 ? code->expr2 : NULL;
stat = code->expr1;
errmsg = code->expr2;
/* Check the stat variable. */
if (stat)
{
if (stat->symtree->n.sym->attr.intent == INTENT_IN)
gfc_error ("Stat-variable '%s' at %L cannot be INTENT(IN)",
stat->symtree->n.sym->name, &stat->where);
if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
gfc_error ("Illegal stat-variable at %L for a PURE procedure",
&stat->where);
gfc_check_vardef_context (stat, false, _("STAT variable"));
if ((stat->ts.type != BT_INTEGER
&& !(stat->ref && (stat->ref->type == REF_ARRAY
@ -6902,13 +6910,7 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
gfc_warning ("ERRMSG at %L is useless without a STAT tag",
&errmsg->where);
if (errmsg->symtree->n.sym->attr.intent == INTENT_IN)
gfc_error ("Errmsg-variable '%s' at %L cannot be INTENT(IN)",
errmsg->symtree->n.sym->name, &errmsg->where);
if (gfc_pure (NULL) && gfc_impure_variable (errmsg->symtree->n.sym))
gfc_error ("Illegal errmsg-variable at %L for a PURE procedure",
&errmsg->where);
gfc_check_vardef_context (errmsg, false, _("ERRMSG variable"));
if ((errmsg->ts.type != BT_CHARACTER
&& !(errmsg->ref
@ -7539,7 +7541,6 @@ static void
resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
{
gfc_expr* target;
bool to_var;
gcc_assert (sym->assoc);
gcc_assert (sym->attr.flavor == FL_VARIABLE);
@ -7573,22 +7574,8 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
gcc_assert (sym->ts.type != BT_UNKNOWN);
/* See if this is a valid association-to-variable. */
to_var = (target->expr_type == EXPR_VARIABLE
&& !gfc_has_vector_subscript (target));
if (sym->assoc->variable && !to_var)
{
if (target->expr_type == EXPR_VARIABLE)
gfc_error ("'%s' at %L associated to vector-indexed target can not"
" be used in a variable definition context",
sym->name, &sym->declared_at);
else
gfc_error ("'%s' at %L associated to expression can not"
" be used in a variable definition context",
sym->name, &sym->declared_at);
return;
}
sym->assoc->variable = to_var;
sym->assoc->variable = (target->expr_type == EXPR_VARIABLE
&& !gfc_has_vector_subscript (target));
/* Finally resolve if this is an array or not. */
if (sym->attr.dimension && target->rank == 0)
@ -7617,7 +7604,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
/* Resolve a SELECT TYPE statement. */
static void
resolve_select_type (gfc_code *code)
resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
{
gfc_symbol *selector_type;
gfc_code *body, *new_st, *if_st, *tail;
@ -7895,8 +7882,13 @@ resolve_select_type (gfc_code *code)
default_case->next = if_st;
}
resolve_select (code);
/* Resolve the internal code. This can not be done earlier because
it requires that the sym->assoc of selectors is set already. */
gfc_current_ns = ns;
gfc_resolve_blocks (code->block, gfc_current_ns);
gfc_current_ns = old_ns;
resolve_select (code);
}
@ -8657,7 +8649,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
}
}
if (lhs->ts.type == BT_CHARACTER
&& gfc_option.warn_character_truncation)
{
@ -8698,15 +8689,6 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
if (gfc_pure (NULL))
{
if (gfc_impure_variable (lhs->symtree->n.sym))
{
gfc_error ("Cannot assign to variable '%s' in PURE "
"procedure at %L",
lhs->symtree->n.sym->name,
&lhs->where);
return rval;
}
if (lhs->ts.type == BT_DERIVED
&& lhs->expr_type == EXPR_VARIABLE
&& lhs->ts.u.derived->attr.pointer_comp
@ -8810,9 +8792,8 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
gfc_resolve_omp_do_blocks (code, ns);
break;
case EXEC_SELECT_TYPE:
gfc_current_ns = code->ext.block.ns;
gfc_resolve_blocks (code->block, gfc_current_ns);
gfc_current_ns = ns;
/* Blocks are handled in resolve_select_type because we have
to transform the SELECT TYPE into ASSOCIATE first. */
break;
case EXEC_OMP_WORKSHARE:
omp_workshare_save = omp_workshare_flag;
@ -8899,6 +8880,10 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
if (t == FAILURE)
break;
if (gfc_check_vardef_context (code->expr1, false, _("assignment"))
== FAILURE)
break;
if (resolve_ordinary_assign (code, ns))
{
if (code->op == EXEC_COMPCALL)
@ -8923,11 +8908,27 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
break;
case EXEC_POINTER_ASSIGN:
if (t == FAILURE)
break;
{
gfc_expr* e;
gfc_check_pointer_assign (code->expr1, code->expr2);
break;
if (t == FAILURE)
break;
/* This is both a variable definition and pointer assignment
context, so check both of them. For rank remapping, a final
array ref may be present on the LHS and fool gfc_expr_attr
used in gfc_check_vardef_context. Remove it. */
e = remove_last_array_ref (code->expr1);
t = gfc_check_vardef_context (e, true, _("pointer assignment"));
if (t == SUCCESS)
t = gfc_check_vardef_context (e, false, _("pointer assignment"));
gfc_free_expr (e);
if (t == FAILURE)
break;
gfc_check_pointer_assign (code->expr1, code->expr2);
break;
}
case EXEC_ARITHMETIC_IF:
if (t == SUCCESS
@ -8970,7 +8971,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
break;
case EXEC_SELECT_TYPE:
resolve_select_type (code);
resolve_select_type (code, ns);
break;
case EXEC_BLOCK:

29
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,32 @@
2010-09-23 Daniel Kraft <d@domob.eu>
PR fortran/38936
PR fortran/44044
PR fortran/45474
* gfortran.dg/intrinsic_intent_1.f03: New test.
* gfortran.dg/select_type_17.f03: New test.
* gfortran.dg/associate_5.f03: More definability tests.
* gfortran.dg/enum_2.f90: Check definability.
* gfortran.dg/allocatable_dummy_2.f90: Change expected error message.
* gfortran.dg/allocate_alloc_opt_2.f90: Ditto.
* gfortran.dg/char_expr_2.f90: Ditto.
* gfortran.dg/deallocate_alloc_opt_2.f90: Ditto.
* gfortran.dg/enum_5.f90: Ditto.
* gfortran.dg/equiv_constraint_8.f90: Ditto.
* gfortran.dg/impure_assignment_2.f90: Ditto.
* gfortran.dg/impure_assignment_3.f90: Ditto.
* gfortran.dg/intent_out_1.f90: Ditto.
* gfortran.dg/intent_out_3.f90: Ditto.
* gfortran.dg/pointer_assign_7.f90: Ditto.
* gfortran.dg/pointer_intent_3.f90: Ditto.
* gfortran.dg/pr19936_1.f90: Ditto.
* gfortran.dg/proc_ptr_comp_3.f90: Ditto.
* gfortran.dg/simpleif_2.f90: Ditto.
* gfortran.dg/protected_5.f90: Ditto.
* gfortran.dg/protected_4.f90: Ditto and remove invalid error check.
* gfortran.dg/protected_6.f90: Ditto.
* gfortran.dg/protected_7.f90: Ditto.
2010-09-22 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libfortran/45710

4
gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90
View File

@ -16,13 +16,13 @@ contains
subroutine init2(x)
integer, allocatable, intent(in) :: x(:)
allocate(x(3)) ! { dg-error "Cannot allocate" }
allocate(x(3)) ! { dg-error "variable definition context" }
end subroutine init2
subroutine kill(x)
integer, allocatable, intent(in) :: x(:)
deallocate(x) ! { dg-error "Cannot deallocate" }
deallocate(x) ! { dg-error "variable definition context" }
end subroutine kill
end program alloc_dummy

6
gcc/testsuite/gfortran.dg/allocate_alloc_opt_2.f90
View File

@ -6,7 +6,7 @@ subroutine sub(i, j, err)
integer, intent(in), allocatable :: i(:)
integer, allocatable :: m(:)
integer n
allocate(i(2)) ! { dg-error "Cannot allocate" "" }
allocate(m(2), stat=j) ! { dg-error "cannot be" "" }
allocate(m(2),stat=n,errmsg=err) ! { dg-error "cannot be" "" }
allocate(i(2)) ! { dg-error "variable definition context" }
allocate(m(2), stat=j) ! { dg-error "variable definition context" }
allocate(m(2),stat=n,errmsg=err) ! { dg-error "variable definition context" }
end subroutine sub

25
gcc/testsuite/gfortran.dg/associate_5.f03
View File

@ -18,9 +18,26 @@ PROGRAM main
ptr => a ! { dg-error "neither TARGET nor POINTER" }
END ASSOCIATE
ASSOCIATE (a => 5, & ! { dg-error "variable definition context" }
b => arr((/ 1, 3 /))) ! { dg-error "variable definition context" }
a = 4
b = 7
ASSOCIATE (a => 5, b => arr((/ 1, 3 /)))
a = 4 ! { dg-error "variable definition context" }
b = 7 ! { dg-error "variable definition context" }
CALL test2 (a) ! { dg-error "variable definition context" }
CALL test2 (b) ! { dg-error "variable definition context" }
END ASSOCIATE
CONTAINS
SUBROUTINE test (x)
INTEGER, INTENT(IN) :: x
ASSOCIATE (y => x) ! { dg-error "variable definition context" }
y = 5 ! { dg-error "variable definition context" }
CALL test2 (x) ! { dg-error "variable definition context" }
END ASSOCIATE
END SUBROUTINE test
ELEMENTAL SUBROUTINE test2 (x)
INTEGER, INTENT(OUT) :: x
x = 5
END SUBROUTINE test2
END PROGRAM main

2
gcc/testsuite/gfortran.dg/char_expr_2.f90
View File

@ -11,5 +11,5 @@ interface
end subroutine foo
end interface
character :: n(5)
call foo( (n) ) ! { dg-error "must be definable" }
call foo( (n) ) ! { dg-error "Non-variable expression" }
end

6
gcc/testsuite/gfortran.dg/deallocate_alloc_opt_2.f90
View File

@ -6,7 +6,7 @@ subroutine sub(i, j, err)
integer, intent(in), allocatable :: i(:)
integer, allocatable :: m(:)
integer n
deallocate(i) ! { dg-error "Cannot deallocate" "" }
deallocate(m, stat=j) ! { dg-error "cannot be" "" }
deallocate(m,stat=n,errmsg=err) ! { dg-error "cannot be" "" }
deallocate(i) ! { dg-error "variable definition context" }
deallocate(m, stat=j) ! { dg-error "variable definition context" }
deallocate(m,stat=n,errmsg=err) ! { dg-error "variable definition context" }
end subroutine sub

2
gcc/testsuite/gfortran.dg/enum_2.f90
View File

@ -9,5 +9,7 @@ program main
enumerator blue = 1 ! { dg-error "Syntax error in ENUMERATOR definition" }
end enum
red = 42 ! { dg-error "variable definition context" }
enumerator :: sun ! { dg-error "ENUM" }
end program main

2
gcc/testsuite/gfortran.dg/enum_5.f90
View File

@ -10,7 +10,7 @@ program main
enumerator :: blue = 1
end enum junk ! { dg-error "Syntax error" }
blue = 10 ! { dg-error " assign to a named constant" }
blue = 10 ! { dg-error "Unexpected assignment" }
end program main ! { dg-error "Expecting END ENUM" }
! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 }

2
gcc/testsuite/gfortran.dg/equiv_constraint_8.f90
View File

@ -9,7 +9,7 @@ pure integer function test(j)
common /z/ i
integer :: k
equivalence(i,k) ! { dg-error "EQUIVALENCE object in the pure" }
k=1 ! { dg-error "in PURE procedure at" }
k=1 ! { dg-error "variable definition context" }
test=i*j
end function test
end

6
gcc/testsuite/gfortran.dg/impure_assignment_2.f90
View File

@ -23,7 +23,7 @@ CONTAINS
TYPE(node_type), POINTER :: node
TYPE(node_type), POINTER :: give_next
give_next => node%next ! { dg-error "Bad target" }
node%next => give_next ! { dg-error "Bad pointer object" }
node%next => give_next ! { dg-error "variable definition context" }
END FUNCTION
! Comment #2
PURE integer FUNCTION give_next2(i)
@ -55,14 +55,14 @@ CONTAINS
TYPE(T1), POINTER :: RES
RES => A ! { dg-error "Bad target" }
RES => B ! { dg-error "Bad target" }
B => RES ! { dg-error "Bad pointer object" }
B => RES ! { dg-error "variable definition context" }
END FUNCTION
PURE FUNCTION TST2(A) RESULT(RES)
TYPE(T1), INTENT(IN), TARGET :: A
TYPE(T1), POINTER :: RES
allocate (RES)
RES = A
B = RES ! { dg-error "Cannot assign" }
B = RES ! { dg-error "variable definition context" }
RES = B
END FUNCTION
END MODULE pr20882

4
gcc/testsuite/gfortran.dg/impure_assignment_3.f90
View File

@ -20,7 +20,7 @@ contains
class is (myType)
x%a = 42.
r3 = 43.
g = 44. ! { dg-error "Cannot assign to variable" }
g = 44. ! { dg-error "variable definition context" }
end select
end subroutine
@ -30,7 +30,7 @@ contains
real :: r2
r1 = 45.
r2 = 46.
g = 47. ! { dg-error "Cannot assign to variable" }
g = 47. ! { dg-error "variable definition context" }
end block
end subroutine

8
gcc/testsuite/gfortran.dg/intent_out_1.f90
View File

@ -3,10 +3,10 @@
! Contributed by Paul Thomas <pault@gcc@gnu.org>
real, parameter :: a =42.0
real :: b
call foo(b + 2.0) ! { dg-error "must be definable" }
call foo(a) ! { dg-error "must be definable" }
call bar(b + 2.0) ! { dg-error "must be definable" }
call bar(a) ! { dg-error "must be definable" }
call foo(b + 2.0) ! { dg-error "variable definition context" }
call foo(a) ! { dg-error "variable definition context" }
call bar(b + 2.0) ! { dg-error "variable definition context" }
call bar(a) ! { dg-error "variable definition context" }
contains
subroutine foo(a)
real, intent(out) :: a

2
gcc/testsuite/gfortran.dg/intent_out_3.f90
View File

@ -15,6 +15,6 @@ CONTAINS
END SUBROUTINE S1
END MODULE M1
USE M1
CALL S1(D1%I(3)) ! { dg-error "must be definable" }
CALL S1(D1%I(3)) ! { dg-error "variable definition context" }
END
! { dg-final { cleanup-modules "m1" } }

11
gcc/testsuite/gfortran.dg/intrinsic_intent_1.f03 Normal file
View File

@ -0,0 +1,11 @@
! { dg-do compile }
! PR fortran/45474
! Definability checks for INTENT([IN]OUT) and intrinsics.
! Contributed by Tobias Burnus, burnus@gcc.gnu.org.
call execute_command_line("date", .true.,(1),1,'aa') ! { dg-error "variable definition context" }
call execute_command_line("date", .true.,1,(1),'aa') ! { dg-error "variable definition context" }
call execute_command_line("date", .true.,1,1,('aa')) ! { dg-error "variable definition context" }
end

2
gcc/testsuite/gfortran.dg/pointer_assign_7.f90
View File

@ -18,7 +18,7 @@ type(face_t), pointer :: face
allocate(face)
allocate(blu)
face%bla => blu ! { dg-error "Pointer assignment to non-POINTER" }
face%bla => blu ! { dg-error "Non-POINTER in pointer association context" }
end program

20
gcc/testsuite/gfortran.dg/pointer_intent_3.f90
View File

@ -19,11 +19,11 @@ program test
contains
subroutine a(p)
integer, pointer,intent(in) :: p
p => null(p)! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
nullify(p) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
allocate(p) ! { dg-error "Cannot allocate INTENT\\(IN\\) variable" }
call c(p) ! { dg-error "is INTENT\\(IN\\) while interface specifies INTENT\\(INOUT\\)" }
deallocate(p) ! { dg-error "Cannot deallocate INTENT\\(IN\\) variable" }
p => null(p)! { dg-error "pointer association context" }
nullify(p) ! { dg-error "pointer association context" }
allocate(p) ! { dg-error "pointer association context" }
call c(p) ! { dg-error "pointer association context" }
deallocate(p) ! { dg-error "pointer association context" }
end subroutine
subroutine c(p)
integer, pointer, intent(inout) :: p
@ -32,10 +32,10 @@ contains
subroutine b(t)
type(myT),intent(in) :: t
t%jp = 5
t%jp => null(t%jp) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
nullify(t%jp) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
t%j = 7 ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
allocate(t%jp) ! { dg-error "Cannot allocate INTENT\\(IN\\) variable" }
deallocate(t%jp) ! { dg-error "Cannot deallocate INTENT\\(IN\\) variable" }
t%jp => null(t%jp) ! { dg-error "pointer association context" }
nullify(t%jp) ! { dg-error "pointer association context" }
t%j = 7 ! { dg-error "variable definition context" }
allocate(t%jp) ! { dg-error "pointer association context" }
deallocate(t%jp) ! { dg-error "pointer association context" }
end subroutine b
end program

2
gcc/testsuite/gfortran.dg/pr19936_1.f90
View File

@ -1,5 +1,5 @@
! { dg-do compile }
program pr19936_1
integer, parameter :: i=4
print *,(/(i,i=1,4)/) ! { dg-error "assign to a named constant" }
print *,(/(i,i=1,4)/) ! { dg-error "variable definition context" }
end program pr19936_1

2
gcc/testsuite/gfortran.dg/proc_ptr_comp_3.f90
View File

@ -38,7 +38,7 @@ type(t) :: x
x%ptr2 => x ! { dg-error "Invalid procedure pointer assignment" }
x => x%ptr2 ! { dg-error "Pointer assignment to non-POINTER" }
x => x%ptr2 ! { dg-error "Non-POINTER in pointer association context" }
print *, x%ptr1() ! { dg-error "attribute conflicts with" }
call x%ptr2() ! { dg-error "attribute conflicts with" }

18
gcc/testsuite/gfortran.dg/protected_4.f90
View File

@ -23,15 +23,15 @@ program main
integer :: j
logical :: asgnd
protected :: j ! { dg-error "only allowed in specification part of a module" }
a = 43 ! { dg-error "Assigning to PROTECTED variable" }
ap => null() ! { dg-error "Assigning to PROTECTED variable" }
nullify(ap) ! { dg-error "Assigning to PROTECTED variable" }
ap => at ! { dg-error "Assigning to PROTECTED variable" }
ap = 3 ! { dg-error "Assigning to PROTECTED variable" }
allocate(ap) ! { dg-error "Assigning to PROTECTED variable" }
ap = 73 ! { dg-error "Assigning to PROTECTED variable" }
call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" }
call pointer_assignments(ap) ! { dg-error "is use-associated with PROTECTED attribute" }
a = 43 ! { dg-error "variable definition context" }
ap => null() ! { dg-error "pointer association context" }
nullify(ap) ! { dg-error "pointer association context" }
ap => at ! { dg-error "pointer association context" }
ap = 3 ! OK
allocate(ap) ! { dg-error "pointer association context" }
ap = 73 ! OK
call increment(a,at) ! { dg-error "variable definition context" }
call pointer_assignments(ap) ! { dg-error "pointer association context" }
asgnd = pointer_check(ap)
contains
subroutine increment(a1,a3)

6
gcc/testsuite/gfortran.dg/protected_5.f90
View File

@ -49,9 +49,9 @@ end module good2
program main
use good2
implicit none
t%j = 15 ! { dg-error "Assigning to PROTECTED variable" }
nullify(t%p) ! { dg-error "Assigning to PROTECTED variable" }
allocate(t%array(15))! { dg-error "Assigning to PROTECTED variable" }
t%j = 15 ! { dg-error "variable definition context" }
nullify(t%p) ! { dg-error "pointer association context" }
allocate(t%array(15))! { dg-error "variable definition context" }
end program main
! { dg-final { cleanup-modules "good1 good2 bad1 bad2" } }

18
gcc/testsuite/gfortran.dg/protected_6.f90
View File

@ -19,15 +19,15 @@ end module protmod
program main
use protmod
implicit none
a = 43 ! { dg-error "Assigning to PROTECTED variable" }
ap => null() ! { dg-error "Assigning to PROTECTED variable" }
nullify(ap) ! { dg-error "Assigning to PROTECTED variable" }
ap => at ! { dg-error "Assigning to PROTECTED variable" }
ap = 3 ! { dg-error "Assigning to PROTECTED variable" }
allocate(ap) ! { dg-error "Assigning to PROTECTED variable" }
ap = 73 ! { dg-error "Assigning to PROTECTED variable" }
call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" }
call pointer_assignments(ap) ! { dg-error "is use-associated with PROTECTED attribute" }
a = 43 ! { dg-error "variable definition context" }
ap => null() ! { dg-error "pointer association context" }
nullify(ap) ! { dg-error "pointer association context" }
ap => at ! { dg-error "pointer association context" }
ap = 3 ! OK
allocate(ap) ! { dg-error "pointer association context" }
ap = 73 ! OK
call increment(a,at) ! { dg-error "variable definition context" }
call pointer_assignments(ap) ! { dg-error "pointer association context" }
contains
subroutine increment(a1,a3)
integer, intent(inout) :: a1, a3

4
gcc/testsuite/gfortran.dg/protected_7.f90
View File

@ -13,8 +13,8 @@ program p
integer, pointer :: unprotected_pointer
! The next two lines should be rejected; see PR 37513 why
! we get such a strange error message.
protected_pointer => unprotected_pointer ! { dg-error "only allowed in specification part" }
protected_pointer = unprotected_pointer ! { dg-error "only allowed in specification part" }
protected_pointer => unprotected_pointer ! { dg-error "pointer association context" }
protected_pointer = unprotected_pointer ! OK
unprotected_pointer => protected_target ! { dg-error "target has PROTECTED attribute" }
unprotected_pointer => protected_pointer ! OK
end program p

44
gcc/testsuite/gfortran.dg/select_type_17.f03 Normal file
View File

@ -0,0 +1,44 @@
! { dg-do compile }
! { dg-options "-std=f2003" }
! PR fortran/44044
! Definability check for select type to expression.
! This is "bonus feature #2" from comment #3 of the PR.
! Contributed by Janus Weil, janus@gcc.gnu.org.
implicit none
type :: t1
integer :: i
end type
type, extends(t1) :: t2
end type
type(t1),target :: x1
type(t2),target :: x2
select type ( y => fun(1) )
type is (t1)
y%i = 1 ! { dg-error "variable definition context" }
type is (t2)
y%i = 2 ! { dg-error "variable definition context" }
end select
contains
function fun(i)
class(t1),pointer :: fun
integer :: i
if (i>0) then
fun => x1
else if (i<0) then
fun => x2
else
fun => NULL()
end if
end function
end

2
gcc/testsuite/gfortran.dg/simpleif_2.f90
View File

@ -10,6 +10,6 @@ module read
subroutine a
integer, parameter :: n = 2
if (i .eq. 0) read(j,*) k
if (i .eq. 0) n = j ! { dg-error "assign to a named constant" "" }
if (i .eq. 0) n = j ! { dg-error "Named constant 'n' in variable definition context" }
end subroutine a
end module read