Skip to content

R
riscv-gcc-1
Commit 2ed8d224 by Paul Thomas
Options

re PR fortran/26074 (Module array cannot be automatic or assumed shape) 

2006-02-13  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26074
	PR fortran/25103
	* resolve.c (resolve_symbol): Extend the requirement that module
	arrays have constant bounds to those in the main program.  At the
	same time simplify the array bounds, to avoiding trapping parameter
	array references, and exclude automatic character length from main
	and modules. Rearrange resolve_symbol and resolve_derived to put as
	each flavor together, as much as is possible and move all specific
	code for flavors FL_VARIABLE, FL_PROCEDURE and FL_PARAMETER into new
	functions.
	(resolve_fl_var_and_proc, resolve_fl_variable, resolve_fl_procedure):
	New functions to do work of resolve_symbol.
	(resolve_index_expr): New function that is called from resolved_symbol
	and is extracted from resolve_charlen.
	(resolve_charlen): Call this new function.
	(resolve_fl_derived): Renamed resolve_derived to be consistent with
	the naming of the new functions for the other flavours.  Change the
	charlen checking so that the style is consistent with other similar
	checks. Add the generation of the gfc_dt_list, removed from resolve_
	symbol.

	PR fortran/20861
	* resolve.c (resolve_actual_arglist): Prevent internal procedures
	from being dummy arguments.

	PR fortran/20871
	* resolve.c (resolve_actual_arglist): Prevent pure but non-intrinsic
	procedures from being dummy arguments.

	PR fortran/25083
	* resolve.c (check_data_variable): Add test that data variable is in
	COMMON.

	PR fortran/25088
	* resolve.c (resolve_call): Add test that the subroutine does not
	have a type.


2006-02-13  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/26074
	PR fortran/25103
	* gfortran.dg/module_parameter_array_refs_1.f90: New test.
	* gfortran.dg/bad_automatic_objects_1.f90: New test.
	* gfortran.dg/automatic_module_variable.f90: Change error message.

	PR fortran/20861
	* gfortran.dg/internal_dummy_1.f90: New test.

	PR fortran/20871
	* gfortran.dg/elemental_non_intrinsic_dummy_1.f90: New test.


	PR fortran/25083
	* gfortran.dg/uncommon_block_data_1.f90: New test.
	* gfortran.dg/equiv_constraint_7.f90: Correct non-compliance of test
	with standard.

	PR fortran/25088
	* gfortran.dg/typed_subroutine_1.f90: New test.

From-SVN: r110926
parent 7cdfcf60
Showing with 649 additions and 358 deletions
gcc/fortran/ChangeLog
2006-02-13 Paul Thomas <pault@gcc.gnu.org>
PR fortran/26074
PR fortran/25103
* resolve.c (resolve_symbol): Extend the requirement that module
arrays have constant bounds to those in the main program. At the
same time simplify the array bounds, to avoiding trapping parameter
array references, and exclude automatic character length from main
and modules. Rearrange resolve_symbol and resolve_derived to put as
each flavor together, as much as is possible and move all specific
code for flavors FL_VARIABLE, FL_PROCEDURE and FL_PARAMETER into new
functions.
(resolve_fl_var_and_proc, resolve_fl_variable, resolve_fl_procedure):
New functions to do work of resolve_symbol.
(resolve_index_expr): New function that is called from resolved_symbol
and is extracted from resolve_charlen.
(resolve_charlen): Call this new function.
(resolve_fl_derived): Renamed resolve_derived to be consistent with
the naming of the new functions for the other flavours. Change the
charlen checking so that the style is consistent with other similar
checks. Add the generation of the gfc_dt_list, removed from resolve_
symbol.
PR fortran/20861
* resolve.c (resolve_actual_arglist): Prevent internal procedures
from being dummy arguments.
PR fortran/20871
* resolve.c (resolve_actual_arglist): Prevent pure but non-intrinsic
procedures from being dummy arguments.
PR fortran/25083
* resolve.c (check_data_variable): Add test that data variable is in
COMMON.
PR fortran/25088
* resolve.c (resolve_call): Add test that the subroutine does not
have a type.
2006-02-12 Erik Edelmann <eedelman@gcc.gnu.org>
PR fortran/25806
......
gcc/fortran/resolve.c
......@@ -815,6 +815,20 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
"actual argument", sym->name, &e->where);
}
if (sym->attr.contained && !sym->attr.use_assoc
&& sym->ns->proc_name->attr.flavor != FL_MODULE)
{
gfc_error ("Internal procedure '%s' is not allowed as an "
"actual argument at %L", sym->name, &e->where);
}
if (sym->attr.elemental && !sym->attr.intrinsic)
{
gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
"allowed as an actual argument at %L", sym->name,
&e->where);
}
/* If the symbol is the function that names the current (or
parent) scope, then we really have a variable reference. */
......@@ -1579,6 +1593,15 @@ resolve_call (gfc_code * c)
{
try t;
if (c->symtree && c->symtree->n.sym
&& c->symtree->n.sym->ts.type != BT_UNKNOWN)
{
gfc_error ("'%s' at %L has a type, which is not consistent with "
"the CALL at %L", c->symtree->n.sym->name,
&c->symtree->n.sym->declared_at, &c->loc);
return FAILURE;
}
/* If the procedure is not internal or module, it must be external and
should be checked for usage. */
if (c->symtree && c->symtree->n.sym
......@@ -4459,6 +4482,24 @@ resolve_values (gfc_symbol * sym)
}
/* Resolve an index expression. */
static try
resolve_index_expr (gfc_expr * e)
{
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
if (gfc_simplify_expr (e, 0) == FAILURE)
return FAILURE;
if (gfc_specification_expr (e) == FAILURE)
return FAILURE;
return SUCCESS;
}
/* Resolve a charlen structure. */
static try
......@@ -4469,224 +4510,217 @@ resolve_charlen (gfc_charlen *cl)
cl->resolved = 1;
if (gfc_resolve_expr (cl->length) == FAILURE)
return FAILURE;
if (gfc_simplify_expr (cl->length, 0) == FAILURE)
return FAILURE;
if (gfc_specification_expr (cl->length) == FAILURE)
if (resolve_index_expr (cl->length) == FAILURE)
return FAILURE;
return SUCCESS;
}
/* Resolve the components of a derived type. */
/* Resolution of common features of flavors variable and procedure. */
static try
resolve_derived (gfc_symbol *sym)
resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
{
gfc_component *c;
for (c = sym->components; c != NULL; c = c->next)
/* Constraints on deferred shape variable. */
if (sym->as == NULL || sym->as->type != AS_DEFERRED)
{
if (c->ts.type == BT_CHARACTER)
if (sym->attr.allocatable)
{
if (resolve_charlen (c->ts.cl) == FAILURE)
if (sym->attr.dimension)
gfc_error ("Allocatable array '%s' at %L must have "
"a deferred shape", sym->name, &sym->declared_at);
else
gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
sym->name, &sym->declared_at);
return FAILURE;
}
if (c->ts.cl->length == NULL
|| !gfc_is_constant_expr (c->ts.cl->length))
if (sym->attr.pointer && sym->attr.dimension)
{
gfc_error ("Character length of component '%s' needs to "
"be a constant specification expression at %L.",
c->name,
c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
gfc_error ("Array pointer '%s' at %L must have a deferred shape",
sym->name, &sym->declared_at);
return FAILURE;
}
}
/* TODO: Anything else that should be done here? */
}
else
{
if (!mp_flag && !sym->attr.allocatable
&& !sym->attr.pointer && !sym->attr.dummy)
{
gfc_error ("Array '%s' at %L cannot have a deferred shape",
sym->name, &sym->declared_at);
return FAILURE;
}
}
return SUCCESS;
}
/* Do anything necessary to resolve a symbol. Right now, we just
assume that an otherwise unknown symbol is a variable. This sort
of thing commonly happens for symbols in module. */
/* Resolve symbols with flavor variable. */
static void
resolve_symbol (gfc_symbol * sym)
static try
resolve_fl_variable (gfc_symbol *sym, int mp_flag)
{
/* Zero if we are checking a formal namespace. */
static int formal_ns_flag = 1;
int formal_ns_save, check_constant, mp_flag;
int i, flag;
gfc_namelist *nl;
gfc_symtree *symtree;
gfc_symtree *this_symtree;
gfc_namespace *ns;
gfc_component *c;
gfc_formal_arglist *arg;
int flag;
int i;
gfc_expr *e;
gfc_expr *constructor_expr;
if (sym->attr.flavor == FL_UNKNOWN)
{
if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
return FAILURE;
/* If we find that a flavorless symbol is an interface in one of the
parent namespaces, find its symtree in this namespace, free the
symbol and set the symtree to point to the interface symbol. */
for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
/* The shape of a main program or module array needs to be constant. */
if (sym->as != NULL
&& sym->ns->proc_name
&& (sym->ns->proc_name->attr.flavor == FL_MODULE
|| sym->ns->proc_name->attr.is_main_program)
&& !sym->attr.use_assoc
&& !sym->attr.allocatable
&& !sym->attr.pointer)
{
symtree = gfc_find_symtree (ns->sym_root, sym->name);
if (symtree && symtree->n.sym->generic)
/* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
has not been simplified; parameter array references. Do the
simplification now. */
flag = 0;
for (i = 0; i < sym->as->rank; i++)
{
this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
sym->name);
sym->refs--;
if (!sym->refs)
gfc_free_symbol (sym);
symtree->n.sym->refs++;
this_symtree->n.sym = symtree->n.sym;
return;
}
e = sym->as->lower[i];
if (e && (resolve_index_expr (e) == FAILURE
|| !gfc_is_constant_expr (e)))
{
flag = 1;
break;
}
/* Otherwise give it a flavor according to such attributes as
it has. */
if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
sym->attr.flavor = FL_VARIABLE;
else
e = sym->as->upper[i];
if (e && (resolve_index_expr (e) == FAILURE
|| !gfc_is_constant_expr (e)))
{
sym->attr.flavor = FL_PROCEDURE;
if (sym->attr.dimension)
sym->attr.function = 1;
flag = 1;
break;
}
}
if (sym->attr.flavor == FL_DERIVED && resolve_derived (sym) == FAILURE)
return;
if (flag)
{
gfc_error ("The module or main program array '%s' at %L must "
"have constant shape", sym->name, &sym->declared_at);
return FAILURE;
}
}
/* Symbols that are module procedures with results (functions) have
the types and array specification copied for type checking in
procedures that call them, as well as for saving to a module
file. These symbols can't stand the scrutiny that their results
can. */
mp_flag = (sym->result != NULL && sym->result != sym);
if (sym->ts.type == BT_CHARACTER)
{
/* Make sure that character string variables with assumed length are
dummy arguments. */
e = sym->ts.cl->length;
if (e == NULL && !sym->attr.dummy && !sym->attr.result)
{
gfc_error ("Entity with assumed character length at %L must be a "
"dummy argument or a PARAMETER", &sym->declared_at);
return FAILURE;
}
/* Assign default type to symbols that need one and don't have one. */
if (sym->ts.type == BT_UNKNOWN)
if (!gfc_is_constant_expr (e)
&& !(e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.flavor == FL_PARAMETER)
&& sym->ns->proc_name
&& (sym->ns->proc_name->attr.flavor == FL_MODULE
|| sym->ns->proc_name->attr.is_main_program)
&& !sym->attr.use_assoc)
{
if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
gfc_set_default_type (sym, 1, NULL);
gfc_error ("'%s' at %L must have constant character length "
"in this context", sym->name, &sym->declared_at);
return FAILURE;
}
}
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
/* Can the symbol have an initializer? */
flag = 0;
if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
|| sym->attr.intrinsic || sym->attr.result)
flag = 1;
else if (sym->attr.dimension && !sym->attr.pointer)
{
/* The specific case of an external procedure should emit an error
in the case that there is no implicit type. */
if (!mp_flag)
gfc_set_default_type (sym, sym->attr.external, NULL);
else
/* Don't allow initialization of automatic arrays. */
for (i = 0; i < sym->as->rank; i++)
{
/* Result may be in another namespace. */
resolve_symbol (sym->result);
sym->ts = sym->result->ts;
sym->as = gfc_copy_array_spec (sym->result->as);
sym->attr.dimension = sym->result->attr.dimension;
sym->attr.pointer = sym->result->attr.pointer;
if (sym->as->lower[i] == NULL
|| sym->as->lower[i]->expr_type != EXPR_CONSTANT
|| sym->as->upper[i] == NULL
|| sym->as->upper[i]->expr_type != EXPR_CONSTANT)
{
flag = 1;
break;
}
}
}
/* Assumed size arrays and assumed shape arrays must be dummy
arguments. */
if (sym->as != NULL
&& (sym->as->type == AS_ASSUMED_SIZE
|| sym->as->type == AS_ASSUMED_SHAPE)
&& sym->attr.dummy == 0)
/* Reject illegal initializers. */
if (sym->value && flag)
{
if (sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array at %L must be a dummy argument",
&sym->declared_at);
if (sym->attr.allocatable)
gfc_error ("Allocatable '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else if (sym->attr.external)
gfc_error ("External '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else if (sym->attr.dummy)
gfc_error ("Dummy '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else if (sym->attr.intrinsic)
gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else if (sym->attr.result)
gfc_error ("Function result '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else
gfc_error ("Assumed shape array at %L must be a dummy argument",
&sym->declared_at);
return;
gfc_error ("Automatic array '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
return FAILURE;
}
/* A parameter array's shape needs to be constant. */
if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL
&& !gfc_is_compile_time_shape (sym->as))
{
gfc_error ("Parameter array '%s' at %L cannot be automatic "
"or assumed shape", sym->name, &sym->declared_at);
return;
}
/* 4th constraint in section 11.3: "If an object of a type for which
component-initialization is specified (R429) appears in the
specification-part of a module and does not have the ALLOCATABLE
or POINTER attribute, the object shall have the SAVE attribute." */
/* A module array's shape needs to be constant. */
constructor_expr = NULL;
if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
constructor_expr = gfc_default_initializer (&sym->ts);
if (sym->ns->proc_name
&& sym->attr.flavor == FL_VARIABLE
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& !sym->attr.use_assoc
&& !sym->attr.allocatable
&& !sym->attr.pointer
&& sym->as != NULL
&& !gfc_is_compile_time_shape (sym->as))
&& constructor_expr
&& !sym->ns->save_all && !sym->attr.save
&& !sym->attr.pointer && !sym->attr.allocatable)
{
gfc_error ("Module array '%s' at %L cannot be automatic "
"or assumed shape", sym->name, &sym->declared_at);
return;
gfc_error("Object '%s' at %L must have the SAVE attribute %s",
sym->name, &sym->declared_at,
"for default initialization of a component");
return FAILURE;
}
/* Make sure that character string variables with assumed length are
dummy arguments. */
/* Assign default initializer. */
if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
&& !sym->attr.pointer)
sym->value = gfc_default_initializer (&sym->ts);
if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
&& sym->ts.type == BT_CHARACTER
&& sym->ts.cl->length == NULL && sym->attr.dummy == 0)
{
gfc_error ("Entity with assumed character length at %L must be a "
"dummy argument or a PARAMETER", &sym->declared_at);
return;
}
return SUCCESS;
}
/* Make sure a parameter that has been implicitly typed still
matches the implicit type, since PARAMETER statements can precede
IMPLICIT statements. */
if (sym->attr.flavor == FL_PARAMETER
&& sym->attr.implicit_type
&& !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
"later IMPLICIT type", sym->name, &sym->declared_at);
/* Resolve a procedure. */
/* Make sure the types of derived parameters are consistent. This
type checking is deferred until resolution because the type may
refer to a derived type from the host. */
if (sym->attr.flavor == FL_PARAMETER
&& sym->ts.type == BT_DERIVED
&& !gfc_compare_types (&sym->ts, &sym->value->ts))
gfc_error ("Incompatible derived type in PARAMETER at %L",
&sym->value->where);
/* Make sure symbols with known intent or optional are really dummy
variable. Because of ENTRY statement, this has to be deferred
until resolution time. */
static try
resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
{
gfc_formal_arglist *arg;
if (! sym->attr.dummy
&& (sym->attr.optional
|| sym->attr.intent != INTENT_UNKNOWN))
{
gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
return;
}
if (sym->attr.function
&& resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
return FAILURE;
if (sym->attr.proc == PROC_ST_FUNCTION)
{
......@@ -4697,39 +4731,114 @@ resolve_symbol (gfc_symbol * sym)
{
gfc_error ("Character-valued statement function '%s' at %L must "
"have constant length", sym->name, &sym->declared_at);
return;
return FAILURE;
}
}
}
/* If a derived type symbol has reached this point, without its
type being declared, we have an error. Notice that most
conditions that produce undefined derived types have already
been dealt with. However, the likes of:
implicit type(t) (t) ..... call foo (t) will get us here if
the type is not declared in the scope of the implicit
statement. Change the type to BT_UNKNOWN, both because it is so
and to prevent an ICE. */
if (sym->ts.type == BT_DERIVED
&& sym->ts.derived->components == NULL)
/* Ensure that derived type formal arguments of a public procedure
are not of a private type. */
if (gfc_check_access(sym->attr.access, sym->ns->default_access))
{
gfc_error ("The derived type '%s' at %L is of type '%s', "
"which has not been defined.", sym->name,
&sym->declared_at, sym->ts.derived->name);
sym->ts.type = BT_UNKNOWN;
return;
for (arg = sym->formal; arg; arg = arg->next)
{
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.derived->attr.use_assoc
&& !gfc_check_access(arg->sym->ts.derived->attr.access,
arg->sym->ts.derived->ns->default_access))
{
gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
"a dummy argument of '%s', which is "
"PUBLIC at %L", arg->sym->name, sym->name,
&sym->declared_at);
/* Stop this message from recurring. */
arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
return FAILURE;
}
}
}
/* If a component of a derived type is of a type declared to be private,
either the derived type definition must contain the PRIVATE statement,
or the derived type must be private. (4.4.1 just after R427) */
if (sym->attr.flavor == FL_DERIVED
&& sym->component_access != ACCESS_PRIVATE
&& gfc_check_access(sym->attr.access, sym->ns->default_access))
/* An external symbol may not have an intializer because it is taken to be
a procedure. */
if (sym->attr.external && sym->value)
{
for (c = sym->components; c; c = c->next)
gfc_error ("External object '%s' at %L may not have an initializer",
sym->name, &sym->declared_at);
return FAILURE;
}
/* 5.1.1.5 of the Standard: A function name declared with an asterisk
char-len-param shall not be array-valued, pointer-valued, recursive
or pure. ....snip... A character value of * may only be used in the
following ways: (i) Dummy arg of procedure - dummy associates with
actual length; (ii) To declare a named constant; or (iii) External
function - but length must be declared in calling scoping unit. */
if (sym->attr.function
&& sym->ts.type == BT_CHARACTER
&& sym->ts.cl && sym->ts.cl->length == NULL)
{
if ((sym->as && sym->as->rank) || (sym->attr.pointer)
|| (sym->attr.recursive) || (sym->attr.pure))
{
if (sym->as && sym->as->rank)
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
"array-valued", sym->name, &sym->declared_at);
if (sym->attr.pointer)
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
"pointer-valued", sym->name, &sym->declared_at);
if (sym->attr.pure)
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
"pure", sym->name, &sym->declared_at);
if (sym->attr.recursive)
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
"recursive", sym->name, &sym->declared_at);
return FAILURE;
}
/* Appendix B.2 of the standard. Contained functions give an
error anyway. Fixed-form is likely to be F77/legacy. */
if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
"'%s' at %L is obsolescent in fortran 95",
sym->name, &sym->declared_at);
}
return SUCCESS;
}
/* Resolve the components of a derived type. */
static try
resolve_fl_derived (gfc_symbol *sym)
{
gfc_component *c;
gfc_dt_list * dt_list;
int i;
for (c = sym->components; c != NULL; c = c->next)
{
if (c->ts.type == BT_CHARACTER)
{
if (c->ts.cl->length == NULL
|| (resolve_charlen (c->ts.cl) == FAILURE)
|| !gfc_is_constant_expr (c->ts.cl->length))
{
gfc_error ("Character length of component '%s' needs to "
"be a constant specification expression at %L.",
c->name,
c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
return FAILURE;
}
}
if (c->ts.type == BT_DERIVED
&& sym->component_access != ACCESS_PRIVATE
&& gfc_check_access(sym->attr.access, sym->ns->default_access)
&& !c->ts.derived->attr.use_assoc
&& !gfc_check_access(c->ts.derived->attr.access,
c->ts.derived->ns->default_access))
......@@ -4737,166 +4846,238 @@ resolve_symbol (gfc_symbol * sym)
gfc_error ("The component '%s' is a PRIVATE type and cannot be "
"a component of '%s', which is PUBLIC at %L",
c->name, sym->name, &sym->declared_at);
return;
return FAILURE;
}
if (c->pointer || c->as == NULL)
continue;
for (i = 0; i < c->as->rank; i++)
{
if (c->as->lower[i] == NULL
|| !gfc_is_constant_expr (c->as->lower[i])
|| (resolve_index_expr (c->as->lower[i]) == FAILURE)
|| c->as->upper[i] == NULL
|| (resolve_index_expr (c->as->upper[i]) == FAILURE)
|| !gfc_is_constant_expr (c->as->upper[i]))
{
gfc_error ("Component '%s' of '%s' at %L must have "
"constant array bounds.",
c->name, sym->name, &c->loc);
return FAILURE;
}
}
}
/* An assumed-size array with INTENT(OUT) shall not be of a type for which
default initialization is defined (5.1.2.4.4). */
/* Add derived type to the derived type list. */
dt_list = gfc_get_dt_list ();
dt_list->next = sym->ns->derived_types;
dt_list->derived = sym;
sym->ns->derived_types = dt_list;
return SUCCESS;
}
static try
resolve_fl_parameter (gfc_symbol *sym)
{
/* A parameter array's shape needs to be constant. */
if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
{
gfc_error ("Parameter array '%s' at %L cannot be automatic "
"or assumed shape", sym->name, &sym->declared_at);
return FAILURE;
}
/* Make sure a parameter that has been implicitly typed still
matches the implicit type, since PARAMETER statements can precede
IMPLICIT statements. */
if (sym->attr.implicit_type
&& !gfc_compare_types (&sym->ts,
gfc_get_default_type (sym, sym->ns)))
{
gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
"later IMPLICIT type", sym->name, &sym->declared_at);
return FAILURE;
}
/* Make sure the types of derived parameters are consistent. This
type checking is deferred until resolution because the type may
refer to a derived type from the host. */
if (sym->ts.type == BT_DERIVED
&& sym->attr.dummy
&& sym->attr.intent == INTENT_OUT
&& sym->as
&& sym->as->type == AS_ASSUMED_SIZE)
&& !gfc_compare_types (&sym->ts, &sym->value->ts))
{
for (c = sym->ts.derived->components; c; c = c->next)
gfc_error ("Incompatible derived type in PARAMETER at %L",
&sym->value->where);
return FAILURE;
}
return SUCCESS;
}
/* Do anything necessary to resolve a symbol. Right now, we just
assume that an otherwise unknown symbol is a variable. This sort
of thing commonly happens for symbols in module. */
static void
resolve_symbol (gfc_symbol * sym)
{
/* Zero if we are checking a formal namespace. */
static int formal_ns_flag = 1;
int formal_ns_save, check_constant, mp_flag;
gfc_namelist *nl;
gfc_symtree *symtree;
gfc_symtree *this_symtree;
gfc_namespace *ns;
gfc_component *c;
if (sym->attr.flavor == FL_UNKNOWN)
{
if (c->initializer)
/* If we find that a flavorless symbol is an interface in one of the
parent namespaces, find its symtree in this namespace, free the
symbol and set the symtree to point to the interface symbol. */
for (ns = gfc_current_ns->parent; ns; ns = ns->parent)
{
gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
"ASSUMED SIZE and so cannot have a default initializer",
sym->name, &sym->declared_at);
symtree = gfc_find_symtree (ns->sym_root, sym->name);
if (symtree && symtree->n.sym->generic)
{
this_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
sym->name);
sym->refs--;
if (!sym->refs)
gfc_free_symbol (sym);
symtree->n.sym->refs++;
this_symtree->n.sym = symtree->n.sym;
return;
}
}
/* Otherwise give it a flavor according to such attributes as
it has. */
if (sym->attr.external == 0 && sym->attr.intrinsic == 0)
sym->attr.flavor = FL_VARIABLE;
else
{
sym->attr.flavor = FL_PROCEDURE;
if (sym->attr.dimension)
sym->attr.function = 1;
}
}
if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
return;
/* Symbols that are module procedures with results (functions) have
the types and array specification copied for type checking in
procedures that call them, as well as for saving to a module
file. These symbols can't stand the scrutiny that their results
can. */
mp_flag = (sym->result != NULL && sym->result != sym);
/* Ensure that derived type formal arguments of a public procedure
are not of a private type. */
if (sym->attr.flavor == FL_PROCEDURE
&& gfc_check_access(sym->attr.access, sym->ns->default_access))
/* Assign default type to symbols that need one and don't have one. */
if (sym->ts.type == BT_UNKNOWN)
{
for (arg = sym->formal; arg; arg = arg->next)
if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER)
gfc_set_default_type (sym, 1, NULL);
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
{
if (arg->sym
&& arg->sym->ts.type == BT_DERIVED
&& !arg->sym->ts.derived->attr.use_assoc
&& !gfc_check_access(arg->sym->ts.derived->attr.access,
arg->sym->ts.derived->ns->default_access))
/* The specific case of an external procedure should emit an error
in the case that there is no implicit type. */
if (!mp_flag)
gfc_set_default_type (sym, sym->attr.external, NULL);
else
{
gfc_error_now ("'%s' is a PRIVATE type and cannot be "
"a dummy argument of '%s', which is PUBLIC at %L",
arg->sym->name, sym->name, &sym->declared_at);
/* Stop this message from recurring. */
arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
return;
/* Result may be in another namespace. */
resolve_symbol (sym->result);
sym->ts = sym->result->ts;
sym->as = gfc_copy_array_spec (sym->result->as);
sym->attr.dimension = sym->result->attr.dimension;
sym->attr.pointer = sym->result->attr.pointer;
}
}
}
/* Constraints on deferred shape variable. */
if (sym->attr.flavor == FL_VARIABLE
|| (sym->attr.flavor == FL_PROCEDURE
&& sym->attr.function))
{
if (sym->as == NULL || sym->as->type != AS_DEFERRED)
{
if (sym->attr.allocatable)
/* Assumed size arrays and assumed shape arrays must be dummy
arguments. */
if (sym->as != NULL
&& (sym->as->type == AS_ASSUMED_SIZE
|| sym->as->type == AS_ASSUMED_SHAPE)
&& sym->attr.dummy == 0)
{
if (sym->attr.dimension)
gfc_error ("Allocatable array '%s' at %L must have "
"a deferred shape", sym->name, &sym->declared_at);
if (sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array at %L must be a dummy argument",
&sym->declared_at);
else
gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
sym->name, &sym->declared_at);
gfc_error ("Assumed shape array at %L must be a dummy argument",
&sym->declared_at);
return;
}
if (sym->attr.pointer && sym->attr.dimension)
/* Make sure symbols with known intent or optional are really dummy
variable. Because of ENTRY statement, this has to be deferred
until resolution time. */
if (!sym->attr.dummy
&& (sym->attr.optional
|| sym->attr.intent != INTENT_UNKNOWN))
{
gfc_error ("Array pointer '%s' at %L must have a deferred shape",
sym->name, &sym->declared_at);
gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
return;
}
}
else
{
if (!mp_flag && !sym->attr.allocatable
&& !sym->attr.pointer && !sym->attr.dummy)
/* If a derived type symbol has reached this point, without its
type being declared, we have an error. Notice that most
conditions that produce undefined derived types have already
been dealt with. However, the likes of:
implicit type(t) (t) ..... call foo (t) will get us here if
the type is not declared in the scope of the implicit
statement. Change the type to BT_UNKNOWN, both because it is so
and to prevent an ICE. */
if (sym->ts.type == BT_DERIVED
&& sym->ts.derived->components == NULL)
{
gfc_error ("Array '%s' at %L cannot have a deferred shape",
sym->name, &sym->declared_at);
gfc_error ("The derived type '%s' at %L is of type '%s', "
"which has not been defined.", sym->name,
&sym->declared_at, sym->ts.derived->name);
sym->ts.type = BT_UNKNOWN;
return;
}
}
}
switch (sym->attr.flavor)
{
case FL_VARIABLE:
/* Can the symbol have an initializer? */
flag = 0;
if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
|| sym->attr.intrinsic || sym->attr.result)
flag = 1;
else if (sym->attr.dimension && !sym->attr.pointer)
/* An assumed-size array with INTENT(OUT) shall not be of a type for which
default initialization is defined (5.1.2.4.4). */
if (sym->ts.type == BT_DERIVED
&& sym->attr.dummy
&& sym->attr.intent == INTENT_OUT
&& sym->as
&& sym->as->type == AS_ASSUMED_SIZE)
{
/* Don't allow initialization of automatic arrays. */
for (i = 0; i < sym->as->rank; i++)
for (c = sym->ts.derived->components; c; c = c->next)
{
if (sym->as->lower[i] == NULL
|| sym->as->lower[i]->expr_type != EXPR_CONSTANT
|| sym->as->upper[i] == NULL
|| sym->as->upper[i]->expr_type != EXPR_CONSTANT)
if (c->initializer)
{
flag = 1;
break;
gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
"ASSUMED SIZE and so cannot have a default initializer",
sym->name, &sym->declared_at);
return;
}
}
}
/* Reject illegal initializers. */
if (sym->value && flag)
switch (sym->attr.flavor)
{
if (sym->attr.allocatable)
gfc_error ("Allocatable '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else if (sym->attr.external)
gfc_error ("External '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else if (sym->attr.dummy)
gfc_error ("Dummy '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else if (sym->attr.intrinsic)
gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else if (sym->attr.result)
gfc_error ("Function result '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
else
gfc_error ("Automatic array '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
case FL_VARIABLE:
if (resolve_fl_variable (sym, mp_flag) == FAILURE)
return;
}
/* 4th constraint in section 11.3: "If an object of a type for which
component-initialization is specified (R429) appears in the
specification-part of a module and does not have the ALLOCATABLE
or POINTER attribute, the object shall have the SAVE attribute." */
constructor_expr = NULL;
if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
constructor_expr = gfc_default_initializer (&sym->ts);
break;
if (sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& constructor_expr
&& !sym->ns->save_all && !sym->attr.save
&& !sym->attr.pointer && !sym->attr.allocatable)
{
gfc_error("Object '%s' at %L must have the SAVE attribute %s",
sym->name, &sym->declared_at,
"for default initialization of a component");
case FL_PROCEDURE:
if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
return;
}
/* Assign default initializer. */
if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
&& !sym->attr.pointer)
sym->value = gfc_default_initializer (&sym->ts);
break;
case FL_NAMELIST:
......@@ -4916,69 +5097,13 @@ resolve_symbol (gfc_symbol * sym)
&sym->declared_at);
}
}
break;
case FL_PROCEDURE:
/* An external symbol may not have an intializer because it is taken to be
a procedure. */
if (sym->attr.external && sym->value)
{
gfc_error ("External object '%s' at %L may not have an initializer",
sym->name, &sym->declared_at);
return;
}
/* 5.1.1.5 of the Standard: A function name declared with an asterisk
char-len-param shall not be array-valued, pointer-valued, recursive
or pure. ....snip... A character value of * may only be used in the
following ways: (i) Dummy arg of procedure - dummy associates with
actual length; (ii) To declare a named constant; or (iii) External
function - but length must be declared in calling scoping unit. */
if (sym->attr.function
&& sym->ts.type == BT_CHARACTER
&& sym->ts.cl && sym->ts.cl->length == NULL)
{
if ((sym->as && sym->as->rank) || (sym->attr.pointer)
|| (sym->attr.recursive) || (sym->attr.pure))
{
if (sym->as && sym->as->rank)
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
"array-valued", sym->name, &sym->declared_at);
if (sym->attr.pointer)
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
"pointer-valued", sym->name, &sym->declared_at);
if (sym->attr.pure)
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
"pure", sym->name, &sym->declared_at);
if (sym->attr.recursive)
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
"recursive", sym->name, &sym->declared_at);
break;
case FL_PARAMETER:
if (resolve_fl_parameter (sym) == FAILURE)
return;
}
/* Appendix B.2 of the standard. Contained functions give an
error anyway. Fixed-form is likely to be F77/legacy. */
if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
"'%s' at %L is obsolescent in fortran 95",
sym->name, &sym->declared_at);
}
break;
case FL_DERIVED:
/* Add derived type to the derived type list. */
{
gfc_dt_list * dt_list;
dt_list = gfc_get_dt_list ();
dt_list->next = sym->ns->derived_types;
dt_list->derived = sym;
sym->ns->derived_types = dt_list;
}
break;
default:
......@@ -5063,6 +5188,13 @@ check_data_variable (gfc_data_variable * var, locus * where)
if (e->expr_type != EXPR_VARIABLE)
gfc_internal_error ("check_data_variable(): Bad expression");
if (e->symtree->n.sym->ns->is_block_data
&& !e->symtree->n.sym->attr.in_common)
{
gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
}
if (e->rank == 0)
{
mpz_init_set_ui (size, 1);
......
gcc/testsuite/ChangeLog
2006-02-13 Paul Thomas <pault@gcc.gnu.org>
PR fortran/26074
PR fortran/25103
* gfortran.dg/module_parameter_array_refs_1.f90: New test.
* gfortran.dg/bad_automatic_objects_1.f90: New test.
* gfortran.dg/automatic_module_variable.f90: Change error message.
PR fortran/20861
* gfortran.dg/internal_dummy_1.f90: New test.
PR fortran/20871
* gfortran.dg/elemental_non_intrinsic_dummy_1.f90: New test.
PR fortran/25083
* gfortran.dg/uncommon_block_data_1.f90: New test.
* gfortran.dg/equiv_constraint_7.f90: Correct non-compliance of test
with standard.
PR fortran/25088
* gfortran.dg/typed_subroutine_1.f90: New test.
2006-02-13 Geoffrey Keating <geoffk@apple.com>
* objc.dg/dwarf-1.m: New.
gcc/testsuite/gfortran.dg/automatic_module_variable.f90
......@@ -4,7 +4,7 @@
module sd
integer, parameter :: n = 20
integer :: i(n)
integer :: j(m) ! { dg-error "cannot be automatic or assumed shape" }
integer :: j(m) ! { dg-error "must have constant shape" }
integer, pointer :: p(:)
integer, allocatable :: q(:)
contains
......
gcc/testsuite/gfortran.dg/bad_automatic_objects_1.f90 0 → 100644
! { dg-do compile }
! Tests the fix for 25103, in which the presence of automatic objects
! in the main program and the specification part of a module was not
! detected.
!
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
!
module foo
integer :: i
end module foo
module bar
use foo
integer, dimension (i) :: j ! { dg-error "must have constant shape" }
character (len = i) :: c1 ! { dg-error "must have constant character length" }
end module bar
program foobar
use foo
integer, dimension (i) :: k ! { dg-error "must have constant shape" }
character (len = i) :: c2 ! { dg-error "must have constant character length" }
end program foobar
gcc/testsuite/gfortran.dg/elemental_non_intrinsic_dummy_1.f90 0 → 100644
! { dg-do compile }
! Tests the fix for 20871, in which elemental non-intrinsic procedures were
! permitted to be dummy arguments.
!
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
!
MODULE TT
CONTAINS
ELEMENTAL INTEGER FUNCTION two(N)
INTEGER, INTENT(IN) :: N
two=2**N
END FUNCTION
END MODULE
USE TT
INTEGER, EXTERNAL :: SUB
write(6,*) SUB(two) ! { dg-error "not allowed as an actual argument " }
END
INTEGER FUNCTION SUB(XX)
INTEGER :: XX
SUB=XX()
END
gcc/testsuite/gfortran.dg/equiv_constraint_7.f90
......@@ -2,8 +2,10 @@
! { dg-options "-O0" }
! PR20890 - Equivalence cannot contain more than one initialized variables.
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
BLOCK DATA
! Started out being in BLOCK DATA; however, blockdata variables must be in
! COMMON and therefore cannot have F95 style initializers....
MODULE DATA
INTEGER :: I=1,J=2
EQUIVALENCE(I,J) ! { dg-error "cannot both be in the EQUIVALENCE" }
END BLOCK DATA
END MODULE DATA
END
gcc/testsuite/gfortran.dg/internal_dummy_1.f90 0 → 100644
! { dg-do compile }
! Tests the fix for 20861, in which internal procedures were permitted to
! be dummy arguments.
!
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
!
CALL DD(TT) ! { dg-error "is not allowed as an actual argument" }
CONTAINS
SUBROUTINE DD(F)
INTERFACE
SUBROUTINE F(X)
REAL :: X
END SUBROUTINE F
END INTERFACE
END SUBROUTINE DD
SUBROUTINE TT(X)
REAL :: X
END SUBROUTINE
END
gcc/testsuite/gfortran.dg/module_parameter_array_refs_1.f90 0 → 100644
! { dg-do compile }
! Tests the fix for 26074, in which the array reference below would
! be determined not to be constant within modules.
!
! Contributed by Jonathan Dursi <ljdursi@cita.utoronto.ca>
!
module foo
integer, parameter :: len = 5
integer :: arr(max(len,1))
end
gcc/testsuite/gfortran.dg/typed_subroutine_1.f90 0 → 100644
! { dg-do compile }
! Tests the fix for 25088, in which the compiler failed to detect that
! a called object had a type.
!
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
!
INTEGER :: S ! { dg-error "has a type, which is not consistent with the CALL " }
CALL S() ! { dg-error "has a type, which is not consistent with the CALL " }
END
SUBROUTINE S
END SUBROUTINE
gcc/testsuite/gfortran.dg/uncommon_block_data_1.f90 0 → 100644
! { dg-do compile }
! Tests the fix for 25083, in which the compiler failed to detect that
! data variables in BLOCK DATA were not in COMMON.
!
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
!
BLOCK DATA D
INTEGER I ! { dg-error "must be in COMMON" }
DATA I /1/
END BLOCK DATA
END
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment