This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: [Patch, fortran] PR26074, PR25103, PR20858, PR20861, PR20871, PR25083 & PR25088 - Joost's PRs
- From: Paul Thomas <paulthomas2 at wanadoo dot fr>
- To: Tobias SchlÃter <tobias dot schlueter at physik dot uni-muenchen dot de>
- Cc: Steve Kargl <sgk at troutmask dot apl dot washington dot edu>, "'fortran at gcc dot gnu dot org'" <fortran at gcc dot gnu dot org>, patch <gcc-patches at gcc dot gnu dot org>
- Date: Sat, 11 Feb 2006 18:10:45 +0100
- Subject: Re: [Patch, fortran] PR26074, PR25103, PR20858, PR20861, PR20871, PR25083 & PR25088 - Joost's PRs
- References: <43E47D62.6070000@wanadoo.fr> <43E4FF1C.4020206@physik.uni-muenchen.de>
Tobi,
The revised patch is attached. I also have attached the modified
ChangeLog entries.
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c (revision 110513)
--- gcc/fortran/expr.c (working copy)
..............snip.............
! if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type <= BT_UNKNOWN)
return SUCCESS;
if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
.LE.?
This part of the patch hase gone because it was superceded by Steve's
more complete fix. Obviously, the associated testcase has gone too.
;
+ if (c->symtree && c->symtree->n.sym
+ && c->symtree->n.sym->ts.type > BT_UNKNOWN)
I'd strongly prefer !=
Done - I was reassured by Paul Brooks' comment that ts.type == 0 cannot
happen unless some dreadful disaster has occurred.
<>*************** resolve_derived (gfc_symbol *sym)
*** 4493,4500 ****
You have no ChangeLog entry for this hunk and the one to resolve_charlen.
I've put that right.
{
case FL_VARIABLE:
! /* The shape of a main program or module array needs to be constant. */
To me it would be clearer if you said "the shape of an array in a main program
or a module needs to be constant."
I presume that you meant in the error message - done.
<>Maybe isolate this into its own function, keeping resolve_symbol
more of an
outline of what its doing so that one can easily find which path it should
proceed through?
I have broken out the cases FL_VARIABLE, FL_PROCEDURE and FL_PARAMETER
into new functions. Also, there was a bit of code common to the first
two that has its own function. resolve_symbol is quite a bit shorter
now. It could be reduced still further. I have a pending patch that
touches FL_NAMELIST; I thought to take that opportunity to create yet
another function. Whilst doing this, I could lift the whole of the
initial part of resolve_symbol that is common to all types and put it in
a new function. In this way, that all that is left is the framework and
the work is done in subroutines. What think you? In the meantime, I
would be happy to leave re-justifying code for a few days!
<>
! /* 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))
{
! 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 a PRIVATE type and cannot be "
^^^^^^^^^^^^^^^^^
! "a dummy argument of '%s', which is "
! "PUBLIC at %L", arg->sym->name, sym->name,
^^^^^^^^^^^^^^
Make that 'is of a PRIVATE type', or replace arg->sym->name by
arg->ts.derived->name. I think the former would be preferable.
Done - the testcase uses the part of the message from PRIVATE onwards.
<>
+ gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
+ e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
+ }
+
Probably not the right place, or do all variables in block data come this way?
If they don't, I was unable to catch them in the act.
Regtested once more on FC3/Athlon. OK for trunk and 4.1?
Paul
2006-02-11 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-11 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.
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 110832)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_actual_arglist (gfc_actual_argli
*** 809,819 ****
|| sym->attr.external)
{
! if (sym->attr.proc == PROC_ST_FUNCTION)
! {
! gfc_error ("Statement function '%s' at %L is not allowed as an "
! "actual argument", sym->name, &e->where);
! }
/* If the symbol is the function that names the current (or
parent) scope, then we really have a variable reference. */
--- 809,833 ----
|| sym->attr.external)
{
! if (sym->attr.proc == PROC_ST_FUNCTION)
! {
! gfc_error ("Statement function '%s' at %L is not allowed as an "
! "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. */
*************** resolve_call (gfc_code * c)
*** 1579,1584 ****
--- 1593,1607 ----
{
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
*************** resolve_values (gfc_symbol * sym)
*** 4459,4464 ****
--- 4482,4505 ----
}
+ /* 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
*************** resolve_charlen (gfc_charlen *cl)
*** 4469,4483 ****
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)
return FAILURE;
return SUCCESS;
}
--- 4510,4812 ----
cl->resolved = 1;
! if (resolve_index_expr (cl->length) == FAILURE)
return FAILURE;
! return SUCCESS;
! }
!
!
! /* Resolution of common features of flavors variable and procedure. */
!
! static try
! resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
! {
! /* Constraints on deferred shape variable. */
! if (sym->as == NULL || sym->as->type != AS_DEFERRED)
! {
! if (sym->attr.allocatable)
! {
! 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 (sym->attr.pointer && sym->attr.dimension)
! {
! gfc_error ("Array pointer '%s' at %L must have a deferred shape",
! sym->name, &sym->declared_at);
! return FAILURE;
! }
!
! }
! 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;
! }
!
! /* Resolve symbols with flavor variable. */
!
! static try
! resolve_fl_variable (gfc_symbol *sym, int mp_flag)
! {
! int flag;
! int i;
! gfc_expr *e;
! gfc_expr *constructor_expr;
!
! if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
return FAILURE;
! /* 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)
! {
! /* 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++)
! {
! e = sym->as->lower[i];
! if (e && (resolve_index_expr (e) == FAILURE
! || !gfc_is_constant_expr (e)))
! {
! flag = 1;
! break;
! }
!
! e = sym->as->upper[i];
! if (e && (resolve_index_expr (e) == FAILURE
! || !gfc_is_constant_expr (e)))
! {
! flag = 1;
! break;
! }
! }
!
! if (flag)
! {
! gfc_error ("The module or main program array '%s' at %L must "
! "have constant shape", sym->name, &sym->declared_at);
! return FAILURE;
! }
! }
!
! 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;
! }
!
! 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)
! {
! gfc_error ("'%s' at %L must have constant character length "
! "in this context", sym->name, &sym->declared_at);
! return FAILURE;
! }
! }
!
! /* 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)
! {
! /* Don't allow initialization of automatic arrays. */
! for (i = 0; i < sym->as->rank; i++)
! {
! 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;
! }
! }
! }
!
! /* Reject illegal initializers. */
! if (sym->value && flag)
! {
! 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);
! return FAILURE;
! }
!
! /* 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
! && 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");
! return FAILURE;
! }
!
! /* Assign default initializer. */
! if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
! && !sym->attr.pointer)
! sym->value = gfc_default_initializer (&sym->ts);
!
! return SUCCESS;
! }
!
!
! /* Resolve a procedure. */
!
! static try
! resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
! {
! gfc_formal_arglist *arg;
!
! if (sym->attr.function
! && resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
return FAILURE;
+ if (sym->attr.proc == PROC_ST_FUNCTION)
+ {
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ gfc_charlen *cl = sym->ts.cl;
+ if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
+ {
+ gfc_error ("Character-valued statement function '%s' at %L must "
+ "have constant length", sym->name, &sym->declared_at);
+ return FAILURE;
+ }
+ }
+ }
+
+ /* 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))
+ {
+ 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;
+ }
+ }
+ }
+
+ /* 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 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_charlen (gfc_charlen *cl)
*** 4485,4502 ****
/* Resolve the components of a derived type. */
static try
! resolve_derived (gfc_symbol *sym)
{
gfc_component *c;
for (c = sym->components; c != NULL; c = c->next)
{
if (c->ts.type == BT_CHARACTER)
{
- if (resolve_charlen (c->ts.cl) == FAILURE)
- return FAILURE;
-
if (c->ts.cl->length == NULL
|| !gfc_is_constant_expr (c->ts.cl->length))
{
gfc_error ("Character length of component '%s' needs to "
--- 4814,4831 ----
/* 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 "
*************** resolve_derived (gfc_symbol *sym)
*** 4507,4518 ****
}
}
! /* TODO: Anything else that should be done here? */
}
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. */
--- 4836,4921 ----
}
}
! 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))
! {
! 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 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;
! }
! }
! }
!
! /* 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
+ && !gfc_compare_types (&sym->ts, &sym->value->ts))
+ {
+ 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. */
*************** resolve_symbol (gfc_symbol * sym)
*** 4523,4536 ****
/* 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;
- gfc_expr *constructor_expr;
if (sym->attr.flavor == FL_UNKNOWN)
{
--- 4926,4936 ----
*************** resolve_symbol (gfc_symbol * sym)
*** 4566,4572 ****
}
}
! if (sym->attr.flavor == FL_DERIVED && resolve_derived (sym) == FAILURE)
return;
/* Symbols that are module procedures with results (functions) have
--- 4966,4972 ----
}
}
! if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
return;
/* Symbols that are module procedures with results (functions) have
*************** resolve_symbol (gfc_symbol * sym)
*** 4618,4686 ****
return;
}
- /* 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;
- }
-
- /* A module array's shape needs to be constant. */
-
- 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))
- {
- gfc_error ("Module array '%s' at %L cannot be automatic "
- "or assumed shape", sym->name, &sym->declared_at);
- return;
- }
-
- /* Make sure that character string variables with assumed length are
- dummy arguments. */
-
- 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;
- }
-
- /* 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);
-
- /* 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. */
! if (! sym->attr.dummy
&& (sym->attr.optional
|| sym->attr.intent != INTENT_UNKNOWN))
{
--- 5018,5028 ----
return;
}
/* 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))
{
*************** resolve_symbol (gfc_symbol * sym)
*** 4688,4707 ****
return;
}
- if (sym->attr.proc == PROC_ST_FUNCTION)
- {
- if (sym->ts.type == BT_CHARACTER)
- {
- gfc_charlen *cl = sym->ts.cl;
- if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
- {
- gfc_error ("Character-valued statement function '%s' at %L must "
- "have constant length", sym->name, &sym->declared_at);
- return;
- }
- }
- }
-
/* 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
--- 5030,5035 ----
*************** resolve_symbol (gfc_symbol * sym)
*** 4720,4747 ****
return;
}
- /* 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))
- {
- for (c = sym->components; c; c = c->next)
- {
- if (c->ts.type == BT_DERIVED
- && !c->ts.derived->attr.use_assoc
- && !gfc_check_access(c->ts.derived->attr.access,
- c->ts.derived->ns->default_access))
- {
- 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;
- }
- }
- }
-
/* 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
--- 5048,5053 ----
*************** resolve_symbol (gfc_symbol * sym)
*** 4762,4902 ****
}
}
-
- /* 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))
- {
- 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 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;
- }
- }
- }
-
- /* 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)
- {
- 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;
- }
-
- if (sym->attr.pointer && sym->attr.dimension)
- {
- gfc_error ("Array pointer '%s' at %L must have a deferred shape",
- sym->name, &sym->declared_at);
- return;
- }
-
- }
- 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;
- }
- }
- }
-
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)
! {
! /* Don't allow initialization of automatic arrays. */
! for (i = 0; i < sym->as->rank; i++)
! {
! 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;
! }
! }
! }
!
! /* Reject illegal initializers. */
! if (sym->value && flag)
! {
! 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);
! 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);
!
! 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");
! 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:
--- 5068,5083 ----
}
}
switch (sym->attr.flavor)
{
case FL_VARIABLE:
! if (resolve_fl_variable (sym, mp_flag) == FAILURE)
! return;
! break;
! case FL_PROCEDURE:
! if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
! return;
break;
case FL_NAMELIST:
*************** resolve_symbol (gfc_symbol * sym)
*** 4916,4984 ****
&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);
-
- 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:
--- 5097,5109 ----
&sym->declared_at);
}
}
break;
! case FL_PARAMETER:
! if (resolve_fl_parameter (sym) == FAILURE)
! return;
!
break;
default:
*************** check_data_variable (gfc_data_variable *
*** 5063,5068 ****
--- 5188,5200 ----
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);
- References:
- [Patch, fortran] PR26074, PR25103, PR20858, PR20861, PR20871, PR25083 & PR25088 - Joost's PRs
- Re: [Patch, fortran] PR26074, PR25103, PR20858, PR20861, PR20871, PR25083 & PR25088 - Joost's PRs