diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 39 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 738 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 23 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/automatic_module_variable.f90 | 2 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/bad_automatic_objects_1.f90 | 20 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/elemental_non_intrinsic_dummy_1.f90 | 21 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/equiv_constraint_7.f90 | 6 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/internal_dummy_1.f90 | 19 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/module_parameter_array_refs_1.f90 | 13 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/typed_subroutine_1.f90 | 11 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/uncommon_block_data_1.f90 | 11 |
11 files changed, 597 insertions, 306 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8551a74..619dd27 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,42 @@ +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 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f8234bf..84d5c7b 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -809,11 +809,25 @@ resolve_actual_arglist (gfc_actual_arglist * arg) || 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.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. */ @@ -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,15 +4510,303 @@ resolve_charlen (gfc_charlen *cl) 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 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; - if (gfc_specification_expr (cl->length) == 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; } @@ -4485,18 +4814,18 @@ resolve_charlen (gfc_charlen *cl) /* Resolve the components of a derived type. */ static try -resolve_derived (gfc_symbol *sym) +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 (resolve_charlen (c->ts.cl) == FAILURE) - return FAILURE; - 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 " @@ -4507,12 +4836,86 @@ resolve_derived (gfc_symbol *sym) } } - /* TODO: Anything else that should be done here? */ + 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. */ @@ -4523,14 +4926,11 @@ 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; - 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) { @@ -4566,7 +4966,7 @@ resolve_symbol (gfc_symbol * sym) } } - if (sym->attr.flavor == FL_DERIVED && resolve_derived (sym) == FAILURE) + if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE) return; /* Symbols that are module procedures with results (functions) have @@ -4618,69 +5018,11 @@ resolve_symbol (gfc_symbol * sym) 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 + if (!sym->attr.dummy && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN)) { @@ -4688,20 +5030,6 @@ resolve_symbol (gfc_symbol * sym) 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 @@ -4720,28 +5048,6 @@ resolve_symbol (gfc_symbol * sym) 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 @@ -4762,141 +5068,16 @@ resolve_symbol (gfc_symbol * 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)) - { - 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; - } + if (resolve_fl_variable (sym, mp_flag) == FAILURE) + return; + break; - /* Assign default initializer. */ - if (sym->ts.type == BT_DERIVED && !(sym->value || flag) - && !sym->attr.pointer) - sym->value = gfc_default_initializer (&sym->ts); + case FL_PROCEDURE: + if (resolve_fl_procedure (sym, mp_flag) == FAILURE) + return; 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); - - 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; - } + case FL_PARAMETER: + if (resolve_fl_parameter (sym) == FAILURE) + return; + 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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index c0b1911..1139140 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,26 @@ +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. diff --git a/gcc/testsuite/gfortran.dg/automatic_module_variable.f90 b/gcc/testsuite/gfortran.dg/automatic_module_variable.f90 index 0cf43f7..201dcf4 100644 --- a/gcc/testsuite/gfortran.dg/automatic_module_variable.f90 +++ b/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 diff --git a/gcc/testsuite/gfortran.dg/bad_automatic_objects_1.f90 b/gcc/testsuite/gfortran.dg/bad_automatic_objects_1.f90 new file mode 100644 index 0000000..2734418 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/bad_automatic_objects_1.f90 @@ -0,0 +1,20 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/elemental_non_intrinsic_dummy_1.f90 b/gcc/testsuite/gfortran.dg/elemental_non_intrinsic_dummy_1.f90 new file mode 100644 index 0000000..c14a5d8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/elemental_non_intrinsic_dummy_1.f90 @@ -0,0 +1,21 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90 b/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90 index ec4579f..207b7d3 100644 --- a/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90 +++ b/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 diff --git a/gcc/testsuite/gfortran.dg/internal_dummy_1.f90 b/gcc/testsuite/gfortran.dg/internal_dummy_1.f90 new file mode 100644 index 0000000..cae187e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/internal_dummy_1.f90 @@ -0,0 +1,19 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/module_parameter_array_refs_1.f90 b/gcc/testsuite/gfortran.dg/module_parameter_array_refs_1.f90 new file mode 100644 index 0000000..a78b525 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/module_parameter_array_refs_1.f90 @@ -0,0 +1,13 @@ +! { 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 + diff --git a/gcc/testsuite/gfortran.dg/typed_subroutine_1.f90 b/gcc/testsuite/gfortran.dg/typed_subroutine_1.f90 new file mode 100644 index 0000000..38619e7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typed_subroutine_1.f90 @@ -0,0 +1,11 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/uncommon_block_data_1.f90 b/gcc/testsuite/gfortran.dg/uncommon_block_data_1.f90 new file mode 100644 index 0000000..54547e8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/uncommon_block_data_1.f90 @@ -0,0 +1,11 @@ +! { 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 |