diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 37 | ||||
| -rw-r--r-- | gcc/fortran/array.c | 2 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 73 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 33 | ||||
| -rw-r--r-- | gcc/fortran/interface.c | 3 | ||||
| -rw-r--r-- | gcc/fortran/match.c | 26 | ||||
| -rw-r--r-- | gcc/fortran/parse.c | 15 | ||||
| -rw-r--r-- | gcc/fortran/primary.c | 16 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 8 | ||||
| -rw-r--r-- | gcc/fortran/symbol.c | 184 |
10 files changed, 233 insertions, 164 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 88b3c14..25bc317 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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. diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index c09bf8b..4f4f19b 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -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; diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 92326e7..9ad5ef1 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -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 (¤t_attr, &seen_at[d]); + t = gfc_add_dimension (¤t_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 (¤t_attr, FL_PARAMETER, &seen_at[d]); + t = gfc_add_flavor (¤t_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 (¤t_attr, ACCESS_PRIVATE, &seen_at[d]); + t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL, + &seen_at[d]); break; case DECL_PUBLIC: - t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, &seen_at[d]); + t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL, + &seen_at[d]); break; case DECL_SAVE: - t = gfc_add_save (¤t_attr, &seen_at[d]); + t = gfc_add_save (¤t_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 (¤t_attr); - gfc_add_dimension (¤t_attr, NULL); + gfc_add_dimension (¤t_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; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index c68f5af..9df2f37 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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_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_function (symbol_attribute *, const char *, locus *); +try gfc_add_subroutine (symbol_attribute *, const char *, 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 *); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index c127568..71555e4 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -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; diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index abd8ef8..2a36447 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -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) diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 484c05c..dac4077 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -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); } } diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index a2d1d1f..f122779 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -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; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 442b205b..dd69a98 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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; diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 7333dbb..b8b6d5e 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -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); } |