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

gfortran.h (gfc_add_dimension, [...]): Add argument. 

* gfortran.h (gfc_add_dimension, gfc_add_result, gfc_add_save,
gfc_add_dummy, gfc_add_generic, gfc_add_in_common, gfc_add_data,
gfc_add_in_namelist, gfc_add_sequence, gfc_add_function,
gfc_add_subroutine, gfc_add_access, gfc_add_flavor, gfc_add_entry,
gfc_add_procedure): Add argument.
* array.c (gfc_set_array_spec), decl.c (var_element, get_proc_name,
gfc_match_null, match_type_spec, match_attr_spec,
gfc_match_formal_arglist, match_result, gfc_match_function_decl):
Update callers to match.
(gfc_match_entry) : Likewise, fix comment typo.
(gfc_match_subroutine, attr_decl1, gfc_add_dimension,
access_attr_decl, do_parm, gfc_match_save, gfc_match_modproc,
gfc_match_derived_decl): Update callers.
* interface.c (gfc_match_interface): Likewise.
* match.c (gfc_match_label, gfc_add_flavor,
gfc_match_call, gfc_match_common, gfc_match_block_data,
gfc_match_namelist, gfc_match_module, gfc_match_st_function):
Likewise.
* parse.c (parse_derived, parse_interface, parse_contained),
primary.c (gfc_match_rvalue, gfc_match_variable): Likewise.
* resolve.c (resolve_formal_arglist, resolve_entries): Update callers.
* symbol.c (check_conflict, check_used): Add new 'name' argument,
use when printing error message.
(gfc_add_dimension, gfc_add_result, gfc_add_save, gfc_add_dummy,
gfc_add_generic, gfc_add_in_common, gfc_add_data,
gfc_add_in_namelist, gfc_add_sequence, gfc_add_function,
gfc_add_subroutine, gfc_add_access, gfc_add_flavor, gfc_add_entry,
gfc_add_procedure): Add new 'name' argument.  Pass along to
check_conflict and check_used.
(gfc_add_allocatable, gfc_add_external, gfc_add_intrinsic,
gfc_add_optional, gfc_add_pointer, gfc_add_target, gfc_add_elemental,
gfc_add_pure, gfc_add_recursive, gfc_add_intent,
gfc_add_explicit_interface, gfc_copy_attr): Pass NULL for new
argument in calls to any of the modified functions.

From-SVN: r94718
This commit is contained in:
Tobias Schlüter 2005-02-07 23:16:13 +01:00 committed by Tobias Schlüter
parent f55db9c2fc
commit 231b2fccf5
10 changed files with 232 additions and 163 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
gcc/fortran/ChangeLog
View File

@ -1,3 +1,40 @@
2005-02-07 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de>
* gfortran.h (gfc_add_dimension, gfc_add_result, gfc_add_save,
gfc_add_dummy, gfc_add_generic, gfc_add_in_common, gfc_add_data,
gfc_add_in_namelist, gfc_add_sequence, gfc_add_function,
gfc_add_subroutine, gfc_add_access, gfc_add_flavor, gfc_add_entry,
gfc_add_procedure): Add argument.
* array.c (gfc_set_array_spec), decl.c (var_element, get_proc_name,
gfc_match_null, match_type_spec, match_attr_spec,
gfc_match_formal_arglist, match_result, gfc_match_function_decl):
Update callers to match.
(gfc_match_entry) : Likewise, fix comment typo.
(gfc_match_subroutine, attr_decl1, gfc_add_dimension,
access_attr_decl, do_parm, gfc_match_save, gfc_match_modproc,
gfc_match_derived_decl): Update callers.
* interface.c (gfc_match_interface): Likewise.
* match.c (gfc_match_label, gfc_add_flavor,
gfc_match_call, gfc_match_common, gfc_match_block_data,
gfc_match_namelist, gfc_match_module, gfc_match_st_function):
Likewise.
* parse.c (parse_derived, parse_interface, parse_contained),
primary.c (gfc_match_rvalue, gfc_match_variable): Likewise.
* resolve.c (resolve_formal_arglist, resolve_entries): Update callers.
* symbol.c (check_conflict, check_used): Add new 'name' argument,
use when printing error message.
(gfc_add_dimension, gfc_add_result, gfc_add_save, gfc_add_dummy,
gfc_add_generic, gfc_add_in_common, gfc_add_data,
gfc_add_in_namelist, gfc_add_sequence, gfc_add_function,
gfc_add_subroutine, gfc_add_access, gfc_add_flavor, gfc_add_entry,
gfc_add_procedure): Add new 'name' argument. Pass along to
check_conflict and check_used.
(gfc_add_allocatable, gfc_add_external, gfc_add_intrinsic,
gfc_add_optional, gfc_add_pointer, gfc_add_target, gfc_add_elemental,
gfc_add_pure, gfc_add_recursive, gfc_add_intent,
gfc_add_explicit_interface, gfc_copy_attr): Pass NULL for new
argument in calls to any of the modified functions.
2005-02-06 Joseph S. Myers <joseph@codesourcery.com>
* gfortran.texi: Don't give last update date.

2
gcc/fortran/array.c
View File

@ -457,7 +457,7 @@ gfc_set_array_spec (gfc_symbol * sym, gfc_array_spec * as, locus * error_loc)
if (as == NULL)
return SUCCESS;
if (gfc_add_dimension (&sym->attr, error_loc) == FAILURE)
if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE)
return FAILURE;
sym->as = as;

73
gcc/fortran/decl.c
View File

@ -198,7 +198,7 @@ var_element (gfc_data_variable * new)
}
#endif
if (gfc_add_data (&sym->attr, &new->expr->where) == FAILURE)
if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
return MATCH_ERROR;
return MATCH_YES;
@ -598,7 +598,8 @@ get_proc_name (const char *name, gfc_symbol ** result)
if (sym->ns->proc_name != NULL
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& sym->attr.proc != PROC_MODULE
&& gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE)
&& gfc_add_procedure (&sym->attr, PROC_MODULE,
sym->name, NULL) == FAILURE)
rc = 2;
return rc;
@ -818,8 +819,9 @@ gfc_match_null (gfc_expr ** result)
gfc_intrinsic_symbol (sym);
if (sym->attr.proc != PROC_INTRINSIC
&& (gfc_add_procedure (&sym->attr, PROC_INTRINSIC, NULL) == FAILURE
|| gfc_add_function (&sym->attr, NULL) == FAILURE))
&& (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
sym->name, NULL) == FAILURE
|| gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
return MATCH_ERROR;
e = gfc_get_expr ();
@ -1369,7 +1371,7 @@ match_type_spec (gfc_typespec * ts, int implicit_flag)
}
if (sym->attr.flavor != FL_DERIVED
&& gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE)
&& gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
ts->type = BT_DERIVED;
@ -1801,7 +1803,7 @@ match_attr_spec (void)
break;
case DECL_DIMENSION:
t = gfc_add_dimension (&current_attr, &seen_at[d]);
t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
break;
case DECL_EXTERNAL:
@ -1829,7 +1831,7 @@ match_attr_spec (void)
break;
case DECL_PARAMETER:
t = gfc_add_flavor (&current_attr, FL_PARAMETER, &seen_at[d]);
t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
break;
case DECL_POINTER:
@ -1837,15 +1839,17 @@ match_attr_spec (void)
break;
case DECL_PRIVATE:
t = gfc_add_access (&current_attr, ACCESS_PRIVATE, &seen_at[d]);
t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
&seen_at[d]);
break;
case DECL_PUBLIC:
t = gfc_add_access (&current_attr, ACCESS_PUBLIC, &seen_at[d]);
t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
&seen_at[d]);
break;
case DECL_SAVE:
t = gfc_add_save (&current_attr, &seen_at[d]);
t = gfc_add_save (&current_attr, NULL, &seen_at[d]);
break;
case DECL_TARGET:
@ -2080,7 +2084,7 @@ gfc_match_formal_arglist (gfc_symbol * progname, int st_flag, int null_flag)
dummy procedure. We don't apply these attributes to formal
arguments of statement functions. */
if (sym != NULL && !st_flag
&& (gfc_add_dummy (&sym->attr, NULL) == FAILURE
&& (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
|| gfc_missing_attr (&sym->attr, NULL) == FAILURE))
{
m = MATCH_ERROR;
@ -2180,8 +2184,8 @@ match_result (gfc_symbol * function, gfc_symbol ** result)
if (gfc_get_symbol (name, NULL, &r))
return MATCH_ERROR;
if (gfc_add_flavor (&r->attr, FL_VARIABLE, NULL) == FAILURE
|| gfc_add_result (&r->attr, NULL) == FAILURE)
if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
|| gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
return MATCH_ERROR;
*result = r;
@ -2251,7 +2255,7 @@ gfc_match_function_decl (void)
/* Make changes to the symbol. */
m = MATCH_ERROR;
if (gfc_add_function (&sym->attr, NULL) == FAILURE)
if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
goto cleanup;
if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
@ -2326,13 +2330,13 @@ gfc_match_entry (void)
if (state == COMP_SUBROUTINE)
{
/* And entry in a subroutine. */
/* An entry in a subroutine. */
m = gfc_match_formal_arglist (entry, 0, 1);
if (m != MATCH_YES)
return MATCH_ERROR;
if (gfc_add_entry (&entry->attr, NULL) == FAILURE
|| gfc_add_subroutine (&entry->attr, NULL) == FAILURE)
if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
|| gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
return MATCH_ERROR;
}
else
@ -2346,8 +2350,8 @@ gfc_match_entry (void)
if (gfc_match_eos () == MATCH_YES)
{
if (gfc_add_entry (&entry->attr, NULL) == FAILURE
|| gfc_add_function (&entry->attr, NULL) == FAILURE)
if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
|| gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
return MATCH_ERROR;
entry->result = proc->result;
@ -2361,9 +2365,10 @@ gfc_match_entry (void)
if (m != MATCH_YES)
return MATCH_ERROR;
if (gfc_add_result (&result->attr, NULL) == FAILURE
|| gfc_add_entry (&entry->attr, NULL) == FAILURE
|| gfc_add_function (&entry->attr, NULL) == FAILURE)
if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
|| gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
|| gfc_add_function (&entry->attr, result->name,
NULL) == FAILURE)
return MATCH_ERROR;
}
@ -2426,7 +2431,7 @@ gfc_match_subroutine (void)
return MATCH_ERROR;
gfc_new_block = sym;
if (gfc_add_subroutine (&sym->attr, NULL) == FAILURE)
if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
@ -2713,7 +2718,7 @@ attr_decl1 (void)
if ((current_attr.external || current_attr.intrinsic)
&& sym->attr.flavor != FL_PROCEDURE
&& gfc_add_flavor (&sym->attr, FL_PROCEDURE, NULL) == FAILURE)
&& gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
@ -2840,7 +2845,7 @@ gfc_match_dimension (void)
{
gfc_clear_attr (&current_attr);
gfc_add_dimension (&current_attr, NULL);
gfc_add_dimension (&current_attr, NULL, NULL);
return attr_decl ();
}
@ -2893,7 +2898,7 @@ access_attr_decl (gfc_statement st)
if (gfc_add_access (&sym->attr,
(st ==
ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
NULL) == FAILURE)
sym->name, NULL) == FAILURE)
return MATCH_ERROR;
break;
@ -3036,7 +3041,7 @@ do_parm (void)
}
if (gfc_check_assign_symbol (sym, init) == FAILURE
|| gfc_add_flavor (&sym->attr, FL_PARAMETER, NULL) == FAILURE)
|| gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
goto cleanup;
@ -3120,7 +3125,8 @@ gfc_match_save (void)
switch (m)
{
case MATCH_YES:
if (gfc_add_save (&sym->attr, &gfc_current_locus) == FAILURE)
if (gfc_add_save (&sym->attr, sym->name,
&gfc_current_locus) == FAILURE)
return MATCH_ERROR;
goto next_item;
@ -3189,7 +3195,8 @@ gfc_match_modproc (void)
return MATCH_ERROR;
if (sym->attr.proc != PROC_MODULE
&& gfc_add_procedure (&sym->attr, PROC_MODULE, NULL) == FAILURE)
&& gfc_add_procedure (&sym->attr, PROC_MODULE,
sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (gfc_add_interface (sym) == FAILURE)
@ -3236,7 +3243,7 @@ loop:
return MATCH_ERROR;
}
if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL) == FAILURE)
if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
return MATCH_ERROR;
goto loop;
}
@ -3249,7 +3256,7 @@ loop:
return MATCH_ERROR;
}
if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL) == FAILURE)
if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
return MATCH_ERROR;
goto loop;
}
@ -3294,7 +3301,7 @@ loop:
derived type that is a pointer. The first part of the AND clause
is true if a the symbol is not the return value of a function. */
if (sym->attr.flavor != FL_DERIVED
&& gfc_add_flavor (&sym->attr, FL_DERIVED, NULL) == FAILURE)
&& gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (sym->components != NULL)
@ -3306,7 +3313,7 @@ loop:
}
if (attr.access != ACCESS_UNKNOWN
&& gfc_add_access (&sym->attr, attr.access, NULL) == FAILURE)
&& gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
gfc_new_block = sym;

31
gcc/fortran/gfortran.h
View File

@ -1573,32 +1573,33 @@ void gfc_get_component_attr (symbol_attribute *, gfc_component *);
void gfc_set_sym_referenced (gfc_symbol * sym);
try gfc_add_allocatable (symbol_attribute *, locus *);
try gfc_add_dimension (symbol_attribute *, locus *);
try gfc_add_dimension (symbol_attribute *, const char *, locus *);
try gfc_add_external (symbol_attribute *, locus *);
try gfc_add_intrinsic (symbol_attribute *, locus *);
try gfc_add_optional (symbol_attribute *, locus *);
try gfc_add_pointer (symbol_attribute *, locus *);
try gfc_add_result (symbol_attribute *, locus *);
try gfc_add_save (symbol_attribute *, locus *);
try gfc_add_result (symbol_attribute *, const char *, locus *);
try gfc_add_save (symbol_attribute *, const char *, locus *);
try gfc_add_saved_common (symbol_attribute *, locus *);
try gfc_add_target (symbol_attribute *, locus *);
try gfc_add_dummy (symbol_attribute *, locus *);
try gfc_add_generic (symbol_attribute *, locus *);
try gfc_add_dummy (symbol_attribute *, const char *, locus *);
try gfc_add_generic (symbol_attribute *, const char *, locus *);
try gfc_add_common (symbol_attribute *, locus *);
try gfc_add_in_common (symbol_attribute *, locus *);
try gfc_add_data (symbol_attribute *, locus *);
try gfc_add_in_namelist (symbol_attribute *, locus *);
try gfc_add_sequence (symbol_attribute *, locus *);
try gfc_add_in_common (symbol_attribute *, const char *, locus *);
try gfc_add_data (symbol_attribute *, const char *, locus *);
try gfc_add_in_namelist (symbol_attribute *, const char *, locus *);
try gfc_add_sequence (symbol_attribute *, const char *, locus *);
try gfc_add_elemental (symbol_attribute *, locus *);
try gfc_add_pure (symbol_attribute *, locus *);
try gfc_add_recursive (symbol_attribute *, locus *);
try gfc_add_function (symbol_attribute *, locus *);
try gfc_add_subroutine (symbol_attribute *, locus *);
try gfc_add_function (symbol_attribute *, const char *, locus *);
try gfc_add_subroutine (symbol_attribute *, const char *, locus *);
try gfc_add_access (symbol_attribute *, gfc_access, locus *);
try gfc_add_flavor (symbol_attribute *, sym_flavor, locus *);
try gfc_add_entry (symbol_attribute *, locus *);
try gfc_add_procedure (symbol_attribute *, procedure_type, locus *);
try gfc_add_access (symbol_attribute *, gfc_access, const char *, locus *);
try gfc_add_flavor (symbol_attribute *, sym_flavor, const char *, locus *);
try gfc_add_entry (symbol_attribute *, const char *, locus *);
try gfc_add_procedure (symbol_attribute *, procedure_type,
const char *, locus *);
try gfc_add_intent (symbol_attribute *, sym_intent, locus *);
try gfc_add_explicit_interface (gfc_symbol *, ifsrc,
gfc_formal_arglist *, locus *);

3
gcc/fortran/interface.c
View File

@ -213,7 +213,8 @@ gfc_match_interface (void)
if (gfc_get_symbol (name, NULL, &sym))
return MATCH_ERROR;
if (!sym->attr.generic && gfc_add_generic (&sym->attr, NULL) == FAILURE)
if (!sym->attr.generic
&& gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
current_interface.sym = gfc_new_block = sym;

26
gcc/fortran/match.c
View File

@ -266,7 +266,8 @@ gfc_match_label (void)
}
if (gfc_new_block->attr.flavor != FL_LABEL
&& gfc_add_flavor (&gfc_new_block->attr, FL_LABEL, NULL) == FAILURE)
&& gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
gfc_new_block->name, NULL) == FAILURE)
return MATCH_ERROR;
for (p = gfc_state_stack; p; p = p->previous)
@ -806,7 +807,7 @@ gfc_match_program (void)
if (m == MATCH_ERROR)
return m;
if (gfc_add_flavor (&sym->attr, FL_PROGRAM, NULL) == FAILURE)
if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
gfc_new_block = sym;
@ -2013,7 +2014,7 @@ gfc_match_call (void)
if (!sym->attr.generic
&& !sym->attr.subroutine
&& gfc_add_subroutine (&sym->attr, NULL) == FAILURE)
&& gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (gfc_match_eos () != MATCH_YES)
@ -2237,7 +2238,7 @@ gfc_match_common (void)
goto cleanup;
}
if (gfc_add_in_common (&sym->attr, NULL) == FAILURE)
if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
goto cleanup;
if (sym->value != NULL
@ -2252,7 +2253,7 @@ gfc_match_common (void)
goto cleanup;
}
if (gfc_add_in_common (&sym->attr, NULL) == FAILURE)
if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
goto cleanup;
/* Derived type names must have the SEQUENCE attribute. */
@ -2287,7 +2288,7 @@ gfc_match_common (void)
goto cleanup;
}
if (gfc_add_dimension (&sym->attr, NULL) == FAILURE)
if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
goto cleanup;
if (sym->attr.pointer)
@ -2353,7 +2354,7 @@ gfc_match_block_data (void)
if (gfc_get_symbol (name, NULL, &sym))
return MATCH_ERROR;
if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, NULL) == FAILURE)
if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
gfc_new_block = sym;
@ -2403,7 +2404,8 @@ gfc_match_namelist (void)
}
if (group_name->attr.flavor != FL_NAMELIST
&& gfc_add_flavor (&group_name->attr, FL_NAMELIST, NULL) == FAILURE)
&& gfc_add_flavor (&group_name->attr, FL_NAMELIST,
group_name->name, NULL) == FAILURE)
return MATCH_ERROR;
for (;;)
@ -2415,7 +2417,7 @@ gfc_match_namelist (void)
goto error;
if (sym->attr.in_namelist == 0
&& gfc_add_in_namelist (&sym->attr, NULL) == FAILURE)
&& gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
goto error;
nl = gfc_get_namelist ();
@ -2471,7 +2473,8 @@ gfc_match_module (void)
if (m != MATCH_YES)
return m;
if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, NULL) == FAILURE)
if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
gfc_new_block->name, NULL) == FAILURE)
return MATCH_ERROR;
return MATCH_YES;
@ -2587,7 +2590,8 @@ gfc_match_st_function (void)
gfc_push_error (&old_error);
if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, NULL) == FAILURE)
if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
sym->name, NULL) == FAILURE)
goto undo_error;
if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)

15
gcc/fortran/parse.c
View File

@ -1349,7 +1349,8 @@ parse_derived (void)
}
seen_sequence = 1;
gfc_add_sequence (&gfc_current_block ()->attr, NULL);
gfc_add_sequence (&gfc_current_block ()->attr,
gfc_current_block ()->name, NULL);
break;
default:
@ -1451,9 +1452,9 @@ loop:
if (current_state == COMP_NONE)
{
if (new_state == COMP_FUNCTION)
gfc_add_function (&sym->attr, NULL);
if (new_state == COMP_SUBROUTINE)
gfc_add_subroutine (&sym->attr, NULL);
gfc_add_function (&sym->attr, sym->name, NULL);
else if (new_state == COMP_SUBROUTINE)
gfc_add_subroutine (&sym->attr, sym->name, NULL);
current_state = new_state;
}
@ -2200,15 +2201,15 @@ parse_contained (int module)
gfc_new_block->name);
else
{
if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
&gfc_new_block->declared_at) ==
SUCCESS)
{
if (st == ST_FUNCTION)
gfc_add_function (&sym->attr,
gfc_add_function (&sym->attr, sym->name,
&gfc_new_block->declared_at);
else
gfc_add_subroutine (&sym->attr,
gfc_add_subroutine (&sym->attr, sym->name,
&gfc_new_block->declared_at);
}
}

16
gcc/fortran/primary.c
View File

@ -1877,7 +1877,7 @@ gfc_match_rvalue (gfc_expr ** result)
e->rank = sym->as->rank;
if (!sym->attr.function
&& gfc_add_function (&sym->attr, NULL) == FAILURE)
&& gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
break;
@ -1905,7 +1905,8 @@ gfc_match_rvalue (gfc_expr ** result)
if (sym->attr.dimension)
{
if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
break;
@ -1930,7 +1931,8 @@ gfc_match_rvalue (gfc_expr ** result)
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
break;
@ -1964,7 +1966,8 @@ gfc_match_rvalue (gfc_expr ** result)
e->expr_type = EXPR_VARIABLE;
if (sym->attr.flavor != FL_VARIABLE
&& gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
&& gfc_add_flavor (&sym->attr, FL_VARIABLE,
sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
break;
@ -1990,7 +1993,7 @@ gfc_match_rvalue (gfc_expr ** result)
e->expr_type = EXPR_FUNCTION;
if (!sym->attr.function
&& gfc_add_function (&sym->attr, NULL) == FAILURE)
&& gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
{
m = MATCH_ERROR;
break;
@ -2072,7 +2075,8 @@ gfc_match_variable (gfc_expr ** result, int equiv_flag)
break;
case FL_UNKNOWN:
if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
sym->name, NULL) == FAILURE)
return MATCH_ERROR;
break;

8
gcc/fortran/resolve.c
View File

@ -151,7 +151,7 @@ resolve_formal_arglist (gfc_symbol * proc)
A procedure specification would have already set the type. */
if (sym->attr.flavor == FL_UNKNOWN)
gfc_add_flavor (&sym->attr, FL_VARIABLE, &sym->declared_at);
gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at);
if (gfc_pure (proc))
{
@ -364,12 +364,12 @@ resolve_entries (gfc_namespace * ns)
gfc_get_ha_symbol (name, &proc);
gcc_assert (proc != NULL);
gfc_add_procedure (&proc->attr, PROC_INTERNAL, NULL);
gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL);
if (ns->proc_name->attr.subroutine)
gfc_add_subroutine (&proc->attr, NULL);
gfc_add_subroutine (&proc->attr, proc->name, NULL);
else
{
gfc_add_function (&proc->attr, NULL);
gfc_add_function (&proc->attr, proc->name, NULL);
gfc_internal_error ("TODO: Functions with alternate entry points");
}
proc->attr.access = ACCESS_PRIVATE;

184
gcc/fortran/symbol.c
View File

@ -237,7 +237,7 @@ gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns)
#define conf2(a) if (attr->a) { a2 = a; goto conflict; }
static try
check_conflict (symbol_attribute * attr, locus * where)
check_conflict (symbol_attribute * attr, const char * name, locus * where)
{
static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
*target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
@ -426,7 +426,13 @@ check_conflict (symbol_attribute * attr, locus * where)
return SUCCESS;
conflict:
gfc_error ("%s attribute conflicts with %s attribute at %L", a1, a2, where);
if (name == NULL)
gfc_error ("%s attribute conflicts with %s attribute at %L",
a1, a2, where);
else
gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
a1, a2, name, where);
return FAILURE;
}
@ -456,7 +462,7 @@ gfc_set_sym_referenced (gfc_symbol * sym)
nonzero if not. */
static int
check_used (symbol_attribute * attr, locus * where)
check_used (symbol_attribute * attr, const char * name, locus * where)
{
if (attr->use_assoc == 0)
@ -465,8 +471,12 @@ check_used (symbol_attribute * attr, locus * where)
if (where == NULL)
where = &gfc_current_locus;
gfc_error ("Cannot change attributes of USE-associated symbol at %L",
where);
if (name == NULL)
gfc_error ("Cannot change attributes of USE-associated symbol at %L",
where);
else
gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
name, where);
return 1;
}
@ -511,7 +521,7 @@ try
gfc_add_allocatable (symbol_attribute * attr, locus * where)
{
if (check_used (attr, where) || check_done (attr, where))
if (check_used (attr, NULL, where) || check_done (attr, where))
return FAILURE;
if (attr->allocatable)
@ -521,15 +531,15 @@ gfc_add_allocatable (symbol_attribute * attr, locus * where)
}
attr->allocatable = 1;
return check_conflict (attr, where);
return check_conflict (attr, NULL, where);
}
try
gfc_add_dimension (symbol_attribute * attr, locus * where)
gfc_add_dimension (symbol_attribute * attr, const char *name, locus * where)
{
if (check_used (attr, where) || check_done (attr, where))
if (check_used (attr, name, where) || check_done (attr, where))
return FAILURE;
if (attr->dimension)
@ -539,7 +549,7 @@ gfc_add_dimension (symbol_attribute * attr, locus * where)
}
attr->dimension = 1;
return check_conflict (attr, where);
return check_conflict (attr, name, where);
}
@ -547,7 +557,7 @@ try
gfc_add_external (symbol_attribute * attr, locus * where)
{
if (check_used (attr, where) || check_done (attr, where))
if (check_used (attr, NULL, where) || check_done (attr, where))
return FAILURE;
if (attr->external)
@ -558,7 +568,7 @@ gfc_add_external (symbol_attribute * attr, locus * where)
attr->external = 1;
return check_conflict (attr, where);
return check_conflict (attr, NULL, where);
}
@ -566,7 +576,7 @@ try
gfc_add_intrinsic (symbol_attribute * attr, locus * where)
{
if (check_used (attr, where) || check_done (attr, where))
if (check_used (attr, NULL, where) || check_done (attr, where))
return FAILURE;
if (attr->intrinsic)
@ -577,7 +587,7 @@ gfc_add_intrinsic (symbol_attribute * attr, locus * where)
attr->intrinsic = 1;
return check_conflict (attr, where);
return check_conflict (attr, NULL, where);
}
@ -585,7 +595,7 @@ try
gfc_add_optional (symbol_attribute * attr, locus * where)
{
if (check_used (attr, where) || check_done (attr, where))
if (check_used (attr, NULL, where) || check_done (attr, where))
return FAILURE;
if (attr->optional)
@ -595,7 +605,7 @@ gfc_add_optional (symbol_attribute * attr, locus * where)
}
attr->optional = 1;
return check_conflict (attr, where);
return check_conflict (attr, NULL, where);
}
@ -603,31 +613,31 @@ try
gfc_add_pointer (symbol_attribute * attr, locus * where)
{
if (check_used (attr, where) || check_done (attr, where))
if (check_used (attr, NULL, where) || check_done (attr, where))
return FAILURE;
attr->pointer = 1;
return check_conflict (attr, where);
return check_conflict (attr, NULL, where);
}
try
gfc_add_result (symbol_attribute * attr, locus * where)
gfc_add_result (symbol_attribute * attr, const char *name, locus * where)
{
if (check_used (attr, where) || check_done (attr, where))
if (check_used (attr, name, where) || check_done (attr, where))
return FAILURE;
attr->result = 1;
return check_conflict (attr, where);
return check_conflict (attr, name, where);
}
try
gfc_add_save (symbol_attribute * attr, locus * where)
gfc_add_save (symbol_attribute * attr, const char *name, locus * where)
{
if (check_used (attr, where))
if (check_used (attr, name, where))
return FAILURE;
if (gfc_pure (NULL))
@ -645,7 +655,7 @@ gfc_add_save (symbol_attribute * attr, locus * where)
}
attr->save = 1;
return check_conflict (attr, where);
return check_conflict (attr, name, where);
}
@ -653,7 +663,7 @@ try
gfc_add_target (symbol_attribute * attr, locus * where)
{
if (check_used (attr, where) || check_done (attr, where))
if (check_used (attr, NULL, where) || check_done (attr, where))
return FAILURE;
if (attr->target)
@ -663,72 +673,73 @@ gfc_add_target (symbol_attribute * attr, locus * where)
}
attr->target = 1;
return check_conflict (attr, where);
return check_conflict (attr, NULL, where);
}
try
gfc_add_dummy (symbol_attribute * attr, locus * where)
gfc_add_dummy (symbol_attribute * attr, const char *name, locus * where)
{
if (check_used (attr, where))
if (check_used (attr, name, where))
return FAILURE;
/* Duplicate dummy arguments are allow due to ENTRY statements. */
attr->dummy = 1;
return check_conflict (attr, where);
return check_conflict (attr, name, where);
}
try
gfc_add_in_common (symbol_attribute * attr, locus * where)
gfc_add_in_common (symbol_attribute * attr, const char *name, locus * where)
{
if (check_used (attr, where) || check_done (attr, where))
if (check_used (attr, name, where) || check_done (attr, where))
return FAILURE;
/* Duplicate attribute already checked for. */
attr->in_common = 1;
if (check_conflict (attr, where) == FAILURE)
if (check_conflict (attr, name, where) == FAILURE)
return FAILURE;
if (attr->flavor == FL_VARIABLE)
return SUCCESS;
return gfc_add_flavor (attr, FL_VARIABLE, where);
return gfc_add_flavor (attr, FL_VARIABLE, name, where);
}
try
gfc_add_data (symbol_attribute *attr, locus *where)
gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
{
if (check_used (attr, where))
if (check_used (attr, name, where))
return FAILURE;
attr->data = 1;
return check_conflict (attr, where);
return check_conflict (attr, name, where);
}
try
gfc_add_in_namelist (symbol_attribute * attr, locus * where)
gfc_add_in_namelist (symbol_attribute * attr, const char *name,
locus * where)
{
attr->in_namelist = 1;
return check_conflict (attr, where);
return check_conflict (attr, name, where);
}
try
gfc_add_sequence (symbol_attribute * attr, locus * where)
gfc_add_sequence (symbol_attribute * attr, const char *name, locus * where)
{
if (check_used (attr, where))
if (check_used (attr, name, where))
return FAILURE;
attr->sequence = 1;
return check_conflict (attr, where);
return check_conflict (attr, name, where);
}
@ -736,11 +747,11 @@ try
gfc_add_elemental (symbol_attribute * attr, locus * where)
{
if (check_used (attr, where) || check_done (attr, where))
if (check_used (attr, NULL, where) || check_done (attr, where))
return FAILURE;
attr->elemental = 1;
return check_conflict (attr, where);
return check_conflict (attr, NULL, where);
}
@ -748,11 +759,11 @@ try
gfc_add_pure (symbol_attribute * attr, locus * where)
{
if (check_used (attr, where) || check_done (attr, where))
if (check_used (attr, NULL, where) || check_done (attr, where))
return FAILURE;
attr->pure = 1;
return check_conflict (attr, where);
return check_conflict (attr, NULL, where);
}
@ -760,19 +771,19 @@ try
gfc_add_recursive (symbol_attribute * attr, locus * where)
{
if (check_used (attr, where) || check_done (attr, where))
if (check_used (attr, NULL, where) || check_done (attr, where))
return FAILURE;
attr->recursive = 1;
return check_conflict (attr, where);
return check_conflict (attr, NULL, where);
}
try
gfc_add_entry (symbol_attribute * attr, locus * where)
gfc_add_entry (symbol_attribute * attr, const char *name, locus * where)
{
if (check_used (attr, where))
if (check_used (attr, name, where))
return FAILURE;
if (attr->entry)
@ -782,46 +793,46 @@ gfc_add_entry (symbol_attribute * attr, locus * where)
}
attr->entry = 1;
return check_conflict (attr, where);
return check_conflict (attr, name, where);
}
try
gfc_add_function (symbol_attribute * attr, locus * where)
gfc_add_function (symbol_attribute * attr, const char *name, locus * where)
{
if (attr->flavor != FL_PROCEDURE
&& gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
&& gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
return FAILURE;
attr->function = 1;
return check_conflict (attr, where);
return check_conflict (attr, name, where);
}
try
gfc_add_subroutine (symbol_attribute * attr, locus * where)
gfc_add_subroutine (symbol_attribute * attr, const char *name, locus * where)
{
if (attr->flavor != FL_PROCEDURE
&& gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
&& gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
return FAILURE;
attr->subroutine = 1;
return check_conflict (attr, where);
return check_conflict (attr, name, where);
}
try
gfc_add_generic (symbol_attribute * attr, locus * where)
gfc_add_generic (symbol_attribute * attr, const char *name, locus * where)
{
if (attr->flavor != FL_PROCEDURE
&& gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
&& gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
return FAILURE;
attr->generic = 1;
return check_conflict (attr, where);
return check_conflict (attr, name, where);
}
@ -829,12 +840,13 @@ gfc_add_generic (symbol_attribute * attr, locus * where)
considers attributes and can be reaffirmed multiple times. */
try
gfc_add_flavor (symbol_attribute * attr, sym_flavor f, locus * where)
gfc_add_flavor (symbol_attribute * attr, sym_flavor f, const char *name,
locus * where)
{
if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
|| f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
|| f == FL_NAMELIST) && check_used (attr, where))
|| f == FL_NAMELIST) && check_used (attr, name, where))
return FAILURE;
if (attr->flavor == f && f == FL_VARIABLE)
@ -854,19 +866,20 @@ gfc_add_flavor (symbol_attribute * attr, sym_flavor f, locus * where)
attr->flavor = f;
return check_conflict (attr, where);
return check_conflict (attr, name, where);
}
try
gfc_add_procedure (symbol_attribute * attr, procedure_type t, locus * where)
gfc_add_procedure (symbol_attribute * attr, procedure_type t,
const char *name, locus * where)
{
if (check_used (attr, where) || check_done (attr, where))
if (check_used (attr, name, where) || check_done (attr, where))
return FAILURE;
if (attr->flavor != FL_PROCEDURE
&& gfc_add_flavor (attr, FL_PROCEDURE, where) == FAILURE)
&& gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
return FAILURE;
if (where == NULL)
@ -886,11 +899,11 @@ gfc_add_procedure (symbol_attribute * attr, procedure_type t, locus * where)
/* Statement functions are always scalar and functions. */
if (t == PROC_ST_FUNCTION
&& ((!attr->function && gfc_add_function (attr, where) == FAILURE)
&& ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
|| attr->dimension))
return FAILURE;
return check_conflict (attr, where);
return check_conflict (attr, name, where);
}
@ -898,13 +911,13 @@ try
gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * where)
{
if (check_used (attr, where))
if (check_used (attr, NULL, where))
return FAILURE;
if (attr->intent == INTENT_UNKNOWN)
{
attr->intent = intent;
return check_conflict (attr, where);
return check_conflict (attr, NULL, where);
}
if (where == NULL)
@ -921,13 +934,14 @@ gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * where)
/* No checks for use-association in public and private statements. */
try
gfc_add_access (symbol_attribute * attr, gfc_access access, locus * where)
gfc_add_access (symbol_attribute * attr, gfc_access access,
const char *name, locus * where)
{
if (attr->access == ACCESS_UNKNOWN)
{
attr->access = access;
return check_conflict (attr, where);
return check_conflict (attr, name, where);
}
if (where == NULL)
@ -943,7 +957,7 @@ gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source,
gfc_formal_arglist * formal, locus * where)
{
if (check_used (&sym->attr, where))
if (check_used (&sym->attr, sym->name, where))
return FAILURE;
if (where == NULL)
@ -1033,37 +1047,37 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
goto fail;
if (src->dimension && gfc_add_dimension (dest, where) == FAILURE)
if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
goto fail;
if (src->optional && gfc_add_optional (dest, where) == FAILURE)
goto fail;
if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
goto fail;
if (src->save && gfc_add_save (dest, where) == FAILURE)
if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
goto fail;
if (src->target && gfc_add_target (dest, where) == FAILURE)
goto fail;
if (src->dummy && gfc_add_dummy (dest, where) == FAILURE)
if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
goto fail;
if (src->result && gfc_add_result (dest, where) == FAILURE)
if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
goto fail;
if (src->entry)
dest->entry = 1;
if (src->in_namelist && gfc_add_in_namelist (dest, where) == FAILURE)
if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
goto fail;
if (src->in_common && gfc_add_in_common (dest, where) == FAILURE)
if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
goto fail;
if (src->generic && gfc_add_generic (dest, where) == FAILURE)
if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
goto fail;
if (src->function && gfc_add_function (dest, where) == FAILURE)
if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
goto fail;
if (src->subroutine && gfc_add_subroutine (dest, where) == FAILURE)
if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
goto fail;
if (src->sequence && gfc_add_sequence (dest, where) == FAILURE)
if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
goto fail;
if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
goto fail;
@ -1073,7 +1087,7 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
goto fail;
if (src->flavor != FL_UNKNOWN
&& gfc_add_flavor (dest, src->flavor, where) == FAILURE)
&& gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
goto fail;
if (src->intent != INTENT_UNKNOWN
@ -1081,7 +1095,7 @@ gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where)
goto fail;
if (src->access != ACCESS_UNKNOWN
&& gfc_add_access (dest, src->access, where) == FAILURE)
&& gfc_add_access (dest, src->access, NULL, where) == FAILURE)
goto fail;
if (gfc_missing_attr (dest, where) == FAILURE)
@ -2326,7 +2340,7 @@ save_symbol (gfc_symbol * sym)
|| sym->attr.flavor != FL_VARIABLE)
return;
gfc_add_save (&sym->attr, &sym->declared_at);
gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
}