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> 2006-02-12 Erik Edelmann <eedelman@gcc.gnu.org>
PR fortran/25806 PR fortran/25806
......
gcc/fortran/resolve.c
...@@ -815,6 +815,20 @@ resolve_actual_arglist (gfc_actual_arglist * arg) ...@@ -815,6 +815,20 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
"actual argument", sym->name, &e->where); "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 /* If the symbol is the function that names the current (or
parent) scope, then we really have a variable reference. */ parent) scope, then we really have a variable reference. */
...@@ -1579,6 +1593,15 @@ resolve_call (gfc_code * c) ...@@ -1579,6 +1593,15 @@ resolve_call (gfc_code * c)
{ {
try t; 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 /* If the procedure is not internal or module, it must be external and
should be checked for usage. */ should be checked for usage. */
if (c->symtree && c->symtree->n.sym if (c->symtree && c->symtree->n.sym
...@@ -4459,6 +4482,24 @@ resolve_values (gfc_symbol * 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. */ /* Resolve a charlen structure. */
static try static try
...@@ -4469,224 +4510,217 @@ resolve_charlen (gfc_charlen *cl) ...@@ -4469,224 +4510,217 @@ resolve_charlen (gfc_charlen *cl)
cl->resolved = 1; cl->resolved = 1;
if (gfc_resolve_expr (cl->length) == FAILURE) if (resolve_index_expr (cl->length) == FAILURE)
return FAILURE;
if (gfc_simplify_expr (cl->length, 0) == FAILURE)
return FAILURE;
if (gfc_specification_expr (cl->length) == FAILURE)
return FAILURE; return FAILURE;
return SUCCESS; return SUCCESS;
} }
/* Resolve the components of a derived type. */ /* Resolution of common features of flavors variable and procedure. */
static try static try
resolve_derived (gfc_symbol *sym) resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
{ {
gfc_component *c; /* Constraints on deferred shape variable. */
if (sym->as == NULL || sym->as->type != AS_DEFERRED)
for (c = sym->components; c != NULL; c = c->next)
{ {
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; return FAILURE;
}
if (c->ts.cl->length == NULL if (sym->attr.pointer && sym->attr.dimension)
|| !gfc_is_constant_expr (c->ts.cl->length))
{ {
gfc_error ("Character length of component '%s' needs to " gfc_error ("Array pointer '%s' at %L must have a deferred shape",
"be a constant specification expression at %L.", sym->name, &sym->declared_at);
c->name,
c->ts.cl->length ? &c->ts.cl->length->where : &c->loc);
return FAILURE; 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; return SUCCESS;
} }
/* Do anything necessary to resolve a symbol. Right now, we just /* Resolve symbols with flavor variable. */
assume that an otherwise unknown symbol is a variable. This sort
of thing commonly happens for symbols in module. */
static void static try
resolve_symbol (gfc_symbol * sym) resolve_fl_variable (gfc_symbol *sym, int mp_flag)
{ {
/* Zero if we are checking a formal namespace. */ int flag;
static int formal_ns_flag = 1; int i;
int formal_ns_save, check_constant, mp_flag; gfc_expr *e;
int i, flag;
gfc_namelist *nl;
gfc_symtree *symtree;
gfc_symtree *this_symtree;
gfc_namespace *ns;
gfc_component *c;
gfc_formal_arglist *arg;
gfc_expr *constructor_expr; 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 /* The shape of a main program or module array needs to be constant. */
parent namespaces, find its symtree in this namespace, free the if (sym->as != NULL
symbol and set the symtree to point to the interface symbol. */ && sym->ns->proc_name
for (ns = gfc_current_ns->parent; ns; ns = ns->parent) && (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); /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
if (symtree && symtree->n.sym->generic) 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, e = sym->as->lower[i];
sym->name); if (e && (resolve_index_expr (e) == FAILURE
sym->refs--; || !gfc_is_constant_expr (e)))
if (!sym->refs) {
gfc_free_symbol (sym); flag = 1;
symtree->n.sym->refs++; break;
this_symtree->n.sym = symtree->n.sym;
return;
}
} }
/* Otherwise give it a flavor according to such attributes as e = sym->as->upper[i];
it has. */ if (e && (resolve_index_expr (e) == FAILURE
if (sym->attr.external == 0 && sym->attr.intrinsic == 0) || !gfc_is_constant_expr (e)))
sym->attr.flavor = FL_VARIABLE;
else
{ {
sym->attr.flavor = FL_PROCEDURE; flag = 1;
if (sym->attr.dimension) break;
sym->attr.function = 1;
} }
} }
if (sym->attr.flavor == FL_DERIVED && resolve_derived (sym) == FAILURE) if (flag)
return; {
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 if (sym->ts.type == BT_CHARACTER)
the types and array specification copied for type checking in {
procedures that call them, as well as for saving to a module /* Make sure that character string variables with assumed length are
file. These symbols can't stand the scrutiny that their results dummy arguments. */
can. */ e = sym->ts.cl->length;
mp_flag = (sym->result != NULL && sym->result != sym); 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 (!gfc_is_constant_expr (e)
if (sym->ts.type == BT_UNKNOWN) && !(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_error ("'%s' at %L must have constant character length "
gfc_set_default_type (sym, 1, NULL); "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 /* Don't allow initialization of automatic arrays. */
in the case that there is no implicit type. */ for (i = 0; i < sym->as->rank; i++)
if (!mp_flag)
gfc_set_default_type (sym, sym->attr.external, NULL);
else
{ {
/* Result may be in another namespace. */ if (sym->as->lower[i] == NULL
resolve_symbol (sym->result); || sym->as->lower[i]->expr_type != EXPR_CONSTANT
|| sym->as->upper[i] == NULL
sym->ts = sym->result->ts; || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
sym->as = gfc_copy_array_spec (sym->result->as); {
sym->attr.dimension = sym->result->attr.dimension; flag = 1;
sym->attr.pointer = sym->result->attr.pointer; break;
} }
} }
} }
/* Assumed size arrays and assumed shape arrays must be dummy /* Reject illegal initializers. */
arguments. */ if (sym->value && flag)
if (sym->as != NULL
&& (sym->as->type == AS_ASSUMED_SIZE
|| sym->as->type == AS_ASSUMED_SHAPE)
&& sym->attr.dummy == 0)
{ {
if (sym->as->type == AS_ASSUMED_SIZE) if (sym->attr.allocatable)
gfc_error ("Assumed size array at %L must be a dummy argument", gfc_error ("Allocatable '%s' at %L cannot have an initializer",
&sym->declared_at); 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 else
gfc_error ("Assumed shape array at %L must be a dummy argument", gfc_error ("Automatic array '%s' at %L cannot have an initializer",
&sym->declared_at); sym->name, &sym->declared_at);
return; return FAILURE;
} }
/* A parameter array's shape needs to be constant. */ /* 4th constraint in section 11.3: "If an object of a type for which
component-initialization is specified (R429) appears in the
if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL specification-part of a module and does not have the ALLOCATABLE
&& !gfc_is_compile_time_shape (sym->as)) or POINTER attribute, the object shall have the SAVE attribute." */
{
gfc_error ("Parameter array '%s' at %L cannot be automatic "
"or assumed shape", sym->name, &sym->declared_at);
return;
}
/* 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 if (sym->ns->proc_name
&& sym->attr.flavor == FL_VARIABLE
&& sym->ns->proc_name->attr.flavor == FL_MODULE && sym->ns->proc_name->attr.flavor == FL_MODULE
&& !sym->attr.use_assoc && constructor_expr
&& !sym->attr.allocatable && !sym->ns->save_all && !sym->attr.save
&& !sym->attr.pointer && !sym->attr.pointer && !sym->attr.allocatable)
&& sym->as != NULL
&& !gfc_is_compile_time_shape (sym->as))
{ {
gfc_error ("Module array '%s' at %L cannot be automatic " gfc_error("Object '%s' at %L must have the SAVE attribute %s",
"or assumed shape", sym->name, &sym->declared_at); sym->name, &sym->declared_at,
return; "for default initialization of a component");
return FAILURE;
} }
/* Make sure that character string variables with assumed length are /* Assign default initializer. */
dummy arguments. */ 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 return SUCCESS;
&& 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;
}
/* 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 /* Resolve a procedure. */
&& 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);
/* Make sure the types of derived parameters are consistent. This static try
type checking is deferred until resolution because the type may resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
refer to a derived type from the host. */ {
gfc_formal_arglist *arg;
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. */
if (! sym->attr.dummy if (sym->attr.function
&& (sym->attr.optional && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
|| sym->attr.intent != INTENT_UNKNOWN)) return FAILURE;
{
gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
return;
}
if (sym->attr.proc == PROC_ST_FUNCTION) if (sym->attr.proc == PROC_ST_FUNCTION)
{ {
...@@ -4697,39 +4731,114 @@ resolve_symbol (gfc_symbol * sym) ...@@ -4697,39 +4731,114 @@ resolve_symbol (gfc_symbol * sym)
{ {
gfc_error ("Character-valued statement function '%s' at %L must " gfc_error ("Character-valued statement function '%s' at %L must "
"have constant length", sym->name, &sym->declared_at); "have constant length", sym->name, &sym->declared_at);
return; return FAILURE;
} }
} }
} }
/* If a derived type symbol has reached this point, without its /* Ensure that derived type formal arguments of a public procedure
type being declared, we have an error. Notice that most are not of a private type. */
conditions that produce undefined derived types have already if (gfc_check_access(sym->attr.access, sym->ns->default_access))
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 ("The derived type '%s' at %L is of type '%s', " for (arg = sym->formal; arg; arg = arg->next)
"which has not been defined.", sym->name, {
&sym->declared_at, sym->ts.derived->name); if (arg->sym
sym->ts.type = BT_UNKNOWN; && arg->sym->ts.type == BT_DERIVED
return; && !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, /* An external symbol may not have an intializer because it is taken to be
either the derived type definition must contain the PRIVATE statement, a procedure. */
or the derived type must be private. (4.4.1 just after R427) */ if (sym->attr.external && sym->value)
if (sym->attr.flavor == FL_DERIVED
&& sym->component_access != ACCESS_PRIVATE
&& gfc_check_access(sym->attr.access, sym->ns->default_access))
{ {
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 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 && !c->ts.derived->attr.use_assoc
&& !gfc_check_access(c->ts.derived->attr.access, && !gfc_check_access(c->ts.derived->attr.access,
c->ts.derived->ns->default_access)) c->ts.derived->ns->default_access))
...@@ -4737,166 +4846,238 @@ resolve_symbol (gfc_symbol * sym) ...@@ -4737,166 +4846,238 @@ resolve_symbol (gfc_symbol * sym)
gfc_error ("The component '%s' is a PRIVATE type and cannot be " gfc_error ("The component '%s' is a PRIVATE type and cannot be "
"a component of '%s', which is PUBLIC at %L", "a component of '%s', which is PUBLIC at %L",
c->name, sym->name, &sym->declared_at); 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 /* Add derived type to the derived type list. */
default initialization is defined (5.1.2.4.4). */ 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 if (sym->ts.type == BT_DERIVED
&& sym->attr.dummy && !gfc_compare_types (&sym->ts, &sym->value->ts))
&& sym->attr.intent == INTENT_OUT
&& sym->as
&& sym->as->type == AS_ASSUMED_SIZE)
{ {
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 " symtree = gfc_find_symtree (ns->sym_root, sym->name);
"ASSUMED SIZE and so cannot have a default initializer", if (symtree && symtree->n.sym->generic)
sym->name, &sym->declared_at); {
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; 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 /* Assign default type to symbols that need one and don't have one. */
are not of a private type. */ if (sym->ts.type == BT_UNKNOWN)
if (sym->attr.flavor == FL_PROCEDURE
&& gfc_check_access(sym->attr.access, sym->ns->default_access))
{ {
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 /* The specific case of an external procedure should emit an error
&& arg->sym->ts.type == BT_DERIVED in the case that there is no implicit type. */
&& !arg->sym->ts.derived->attr.use_assoc if (!mp_flag)
&& !gfc_check_access(arg->sym->ts.derived->attr.access, gfc_set_default_type (sym, sym->attr.external, NULL);
arg->sym->ts.derived->ns->default_access)) else
{ {
gfc_error_now ("'%s' is a PRIVATE type and cannot be " /* Result may be in another namespace. */
"a dummy argument of '%s', which is PUBLIC at %L", resolve_symbol (sym->result);
arg->sym->name, sym->name, &sym->declared_at);
/* Stop this message from recurring. */ sym->ts = sym->result->ts;
arg->sym->ts.derived->attr.access = ACCESS_PUBLIC; sym->as = gfc_copy_array_spec (sym->result->as);
return; sym->attr.dimension = sym->result->attr.dimension;
sym->attr.pointer = sym->result->attr.pointer;
} }
} }
} }
/* Constraints on deferred shape variable. */ /* Assumed size arrays and assumed shape arrays must be dummy
if (sym->attr.flavor == FL_VARIABLE arguments. */
|| (sym->attr.flavor == FL_PROCEDURE
&& sym->attr.function)) if (sym->as != NULL
{ && (sym->as->type == AS_ASSUMED_SIZE
if (sym->as == NULL || sym->as->type != AS_DEFERRED) || sym->as->type == AS_ASSUMED_SHAPE)
{ && sym->attr.dummy == 0)
if (sym->attr.allocatable)
{ {
if (sym->attr.dimension) if (sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Allocatable array '%s' at %L must have " gfc_error ("Assumed size array at %L must be a dummy argument",
"a deferred shape", sym->name, &sym->declared_at); &sym->declared_at);
else else
gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE", gfc_error ("Assumed shape array at %L must be a dummy argument",
sym->name, &sym->declared_at); &sym->declared_at);
return; 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", gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at);
sym->name, &sym->declared_at);
return; return;
} }
} /* If a derived type symbol has reached this point, without its
else type being declared, we have an error. Notice that most
{ conditions that produce undefined derived types have already
if (!mp_flag && !sym->attr.allocatable been dealt with. However, the likes of:
&& !sym->attr.pointer && !sym->attr.dummy) 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", gfc_error ("The derived type '%s' at %L is of type '%s', "
sym->name, &sym->declared_at); "which has not been defined.", sym->name,
&sym->declared_at, sym->ts.derived->name);
sym->ts.type = BT_UNKNOWN;
return; return;
} }
}
}
switch (sym->attr.flavor) /* An assumed-size array with INTENT(OUT) shall not be of a type for which
{ default initialization is defined (5.1.2.4.4). */
case FL_VARIABLE: if (sym->ts.type == BT_DERIVED
/* Can the symbol have an initializer? */ && sym->attr.dummy
flag = 0; && sym->attr.intent == INTENT_OUT
if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy && sym->as
|| sym->attr.intrinsic || sym->attr.result) && sym->as->type == AS_ASSUMED_SIZE)
flag = 1;
else if (sym->attr.dimension && !sym->attr.pointer)
{ {
/* Don't allow initialization of automatic arrays. */ for (c = sym->ts.derived->components; c; c = c->next)
for (i = 0; i < sym->as->rank; i++)
{ {
if (sym->as->lower[i] == NULL if (c->initializer)
|| sym->as->lower[i]->expr_type != EXPR_CONSTANT
|| sym->as->upper[i] == NULL
|| sym->as->upper[i]->expr_type != EXPR_CONSTANT)
{ {
flag = 1; gfc_error ("The INTENT(OUT) dummy argument '%s' at %L is "
break; "ASSUMED SIZE and so cannot have a default initializer",
sym->name, &sym->declared_at);
return;
} }
} }
} }
/* Reject illegal initializers. */ switch (sym->attr.flavor)
if (sym->value && flag)
{ {
if (sym->attr.allocatable) case FL_VARIABLE:
gfc_error ("Allocatable '%s' at %L cannot have an initializer", if (resolve_fl_variable (sym, mp_flag) == FAILURE)
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);
return; return;
} break;
/* 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);
if (sym->ns->proc_name case FL_PROCEDURE:
&& sym->ns->proc_name->attr.flavor == FL_MODULE if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
&& 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");
return; return;
}
/* Assign default initializer. */
if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
&& !sym->attr.pointer)
sym->value = gfc_default_initializer (&sym->ts);
break; break;
case FL_NAMELIST: case FL_NAMELIST:
...@@ -4916,69 +5097,13 @@ resolve_symbol (gfc_symbol * sym) ...@@ -4916,69 +5097,13 @@ resolve_symbol (gfc_symbol * sym)
&sym->declared_at); &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) break;
gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
"recursive", sym->name, &sym->declared_at);
case FL_PARAMETER:
if (resolve_fl_parameter (sym) == FAILURE)
return; 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; break;
default: default:
...@@ -5063,6 +5188,13 @@ check_data_variable (gfc_data_variable * var, locus * where) ...@@ -5063,6 +5188,13 @@ check_data_variable (gfc_data_variable * var, locus * where)
if (e->expr_type != EXPR_VARIABLE) if (e->expr_type != EXPR_VARIABLE)
gfc_internal_error ("check_data_variable(): Bad expression"); 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) if (e->rank == 0)
{ {
mpz_init_set_ui (size, 1); 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> 2006-02-13 Geoffrey Keating <geoffk@apple.com>
* objc.dg/dwarf-1.m: New. * objc.dg/dwarf-1.m: New.
gcc/testsuite/gfortran.dg/automatic_module_variable.f90
...@@ -4,7 +4,7 @@ ...@@ -4,7 +4,7 @@
module sd module sd
integer, parameter :: n = 20 integer, parameter :: n = 20
integer :: i(n) 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, pointer :: p(:)
integer, allocatable :: q(:) integer, allocatable :: q(:)
contains 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 @@ ...@@ -2,8 +2,10 @@
! { dg-options "-O0" } ! { dg-options "-O0" }
! PR20890 - Equivalence cannot contain more than one initialized variables. ! PR20890 - Equivalence cannot contain more than one initialized variables.
! Contributed by Joost VandeVondele <jv244@cam.ac.uk> ! 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 INTEGER :: I=1,J=2
EQUIVALENCE(I,J) ! { dg-error "cannot both be in the EQUIVALENCE" } EQUIVALENCE(I,J) ! { dg-error "cannot both be in the EQUIVALENCE" }
END BLOCK DATA END MODULE DATA
END 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