From: Bernhard Reutner-Fischer <al...@gcc.gnu.org>
This replaces the remaining occurrences of names and name manipulation
to go through the stringpool. Required to make TYPE (IS) handling work
later on.
gcc/fortran/ChangeLog:
2017-11-14 Bernhard Reutner-Fischer <al...@gcc.gnu.org>
* class.c (gfc_build_class_symbol): Use pointer for name.
(generate_finalization_wrapper): Likewise.
(gfc_find_derived_vtab): Likewise.
(find_intrinsic_vtab): Likewise.
* decl.c (gfc_get_pdt_instance): Likewise.
* frontend-passes.c (create_do_loop): Likewise.
* match.c (select_intrinsic_set_tmp): Likewise.
* resolve.c (resolve_select_type): Likewise.
(resolve_critical): Likewise.
(get_temp_from_expr): Likewise.
(resolve_component): Likewise.
* trans-expr.c (alloc_scalar_allocatable_for_subcomponent_assignment):
Likewise.
* trans.c (gfc_deferred_strlen): Likewise.
---
gcc/fortran/class.c | 44 ++++++++++++++++-------------------
gcc/fortran/decl.c | 2 +-
gcc/fortran/frontend-passes.c | 6 ++---
gcc/fortran/match.c | 6 ++---
gcc/fortran/resolve.c | 30 +++++++++++-------------
gcc/fortran/trans-expr.c | 4 ++--
gcc/fortran/trans.c | 6 ++---
7 files changed, 46 insertions(+), 52 deletions(-)
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 8e637689fae..c2dc3411811 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -602,7 +602,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute
*attr,
gfc_array_spec **as)
{
char tname[GFC_MAX_SYMBOL_LEN+1];
- char *name;
+ const char *name;
gfc_symbol *fclass;
gfc_symbol *vtab;
gfc_component *c;
@@ -633,17 +633,17 @@ gfc_build_class_symbol (gfc_typespec *ts,
symbol_attribute *attr,
rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
get_unique_hashed_string (tname, ts->u.derived);
if ((*as) && attr->allocatable)
- name = xasprintf ("__class_%s_%d_%da", tname, rank, (*as)->corank);
+ name = gfc_get_string ("__class_%s_%d_%da", tname, rank, (*as)->corank);
else if ((*as) && attr->pointer)
- name = xasprintf ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
+ name = gfc_get_string ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
else if ((*as))
- name = xasprintf ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
+ name = gfc_get_string ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
else if (attr->pointer)
- name = xasprintf ("__class_%s_p", tname);
+ name = gfc_get_string ("__class_%s_p", tname);
else if (attr->allocatable)
- name = xasprintf ("__class_%s_a", tname);
+ name = gfc_get_string ("__class_%s_a", tname);
else
- name = xasprintf ("__class_%s_t", tname);
+ name = gfc_get_string ("__class_%s_t", tname);
if (ts->u.derived->attr.unlimited_polymorphic)
{
@@ -738,7 +738,6 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute
*attr,
ts->u.derived = fclass;
attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
(*as) = NULL;
- free (name);
return true;
}
@@ -1528,7 +1527,7 @@ generate_finalization_wrapper (gfc_symbol *derived,
gfc_namespace *ns,
gfc_component *comp;
gfc_namespace *sub_ns;
gfc_code *last_code, *block;
- char *name;
+ const char *name;
bool finalizable_comp = false;
bool expr_null_wrapper = false;
gfc_expr *ancestor_wrapper = NULL, *rank;
@@ -1607,7 +1606,7 @@ generate_finalization_wrapper (gfc_symbol *derived,
gfc_namespace *ns,
sub_ns->resolved = 1;
/* Set up the procedure symbol. */
- name = xasprintf ("__final_%s", tname);
+ name = gfc_get_string ("__final_%s", tname);
gfc_get_symbol (name, sub_ns, &final);
sub_ns->proc_name = final;
final->attr.flavor = FL_PROCEDURE;
@@ -2173,7 +2172,6 @@ generate_finalization_wrapper (gfc_symbol *derived,
gfc_namespace *ns,
gfc_free_expr (rank);
vtab_final->initializer = gfc_lval_expr_from_sym (final);
vtab_final->ts.interface = final;
- free (name);
}
@@ -2242,10 +2240,10 @@ gfc_find_derived_vtab (gfc_symbol *derived)
if (ns)
{
char tname[GFC_MAX_SYMBOL_LEN+1];
- char *name;
+ const char *name;
get_unique_hashed_string (tname, derived);
- name = xasprintf ("__vtab_%s", tname);
+ name = gfc_get_string ("__vtab_%s", tname);
/* Look for the vtab symbol in various namespaces. */
if (gsym && gsym->ns)
@@ -2273,7 +2271,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
vtab->attr.vtab = 1;
vtab->attr.access = ACCESS_PUBLIC;
gfc_set_sym_referenced (vtab);
- name = xasprintf ("__vtype_%s", tname);
+ name = gfc_get_string ("__vtype_%s", tname);
gfc_find_symbol (name, ns, 0, &vtype);
if (vtype == NULL)
@@ -2376,7 +2374,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
else
{
/* Construct default initialization variable. */
- name = xasprintf ("__def_init_%s", tname);
+ name = gfc_get_string ("__def_init_%s", tname);
gfc_get_symbol (name, ns, &def_init);
def_init->attr.target = 1;
def_init->attr.artificial = 1;
@@ -2409,7 +2407,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
ns->contained = sub_ns;
sub_ns->resolved = 1;
/* Set up procedure symbol. */
- name = xasprintf ("__copy_%s", tname);
+ name = gfc_get_string ("__copy_%s", tname);
gfc_get_symbol (name, sub_ns, ©);
sub_ns->proc_name = copy;
copy->attr.flavor = FL_PROCEDURE;
@@ -2486,7 +2484,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
ns->contained = sub_ns;
sub_ns->resolved = 1;
/* Set up procedure symbol. */
- name = xasprintf ("__deallocate_%s", tname);
+ name = gfc_get_string ("__deallocate_%s", tname);
gfc_get_symbol (name, sub_ns, &dealloc);
sub_ns->proc_name = dealloc;
dealloc->attr.flavor = FL_PROCEDURE;
@@ -2535,7 +2533,6 @@ have_vtype:
vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
- free (name);
}
found_sym = vtab;
@@ -2628,13 +2625,13 @@ find_intrinsic_vtab (gfc_typespec *ts)
if (ns)
{
char tname[GFC_MAX_SYMBOL_LEN+1];
- char *name;
+ const char *name;
/* Encode all types as TYPENAME_KIND_ including especially character
arrays, whose length is now consistently stored in the _len component
of the class-variable. */
sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
- name = xasprintf ("__vtab_%s", tname);
+ name = gfc_get_string ("__vtab_%s", tname);
/* Look for the vtab symbol in the top-level namespace only. */
gfc_find_symbol (name, ns, 0, &vtab);
@@ -2651,7 +2648,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
vtab->attr.vtab = 1;
vtab->attr.access = ACCESS_PUBLIC;
gfc_set_sym_referenced (vtab);
- name = xasprintf ("__vtype_%s", tname);
+ name = gfc_get_string ("__vtype_%s", tname);
gfc_find_symbol (name, ns, 0, &vtype);
if (vtype == NULL)
@@ -2727,12 +2724,12 @@ find_intrinsic_vtab (gfc_typespec *ts)
c->tb->ppc = 1;
if (ts->type != BT_CHARACTER)
- name = xasprintf ("__copy_%s", tname);
+ name = gfc_get_string ("__copy_%s", tname);
else
{
/* __copy is always the same for characters.
Check to see if copy function already exists. */
- name = xasprintf ("__copy_character_%d", ts->kind);
+ name = gfc_get_string ("__copy_character_%d", ts->kind);
contained = ns->contained;
for (; contained; contained = contained->sibling)
if (contained->proc_name
@@ -2801,7 +2798,6 @@ find_intrinsic_vtab (gfc_typespec *ts)
vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
- free (name);
}
found_sym = vtab;
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 2baa1783434..48ef5637e36 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -3582,7 +3582,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list,
gfc_symbol **sym,
/* Now we search for the PDT instance 'name'. If it doesn't exist, we
build it, using 'pdt' as a template. */
- if (gfc_get_symbol (name, pdt->ns, &instance))
+ if (gfc_get_symbol (gfc_get_string ("%s", name), pdt->ns, &instance))
{
gfc_error ("Parameterized derived type at %C is ambiguous");
goto error_return;
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index 0a5e8937015..d549d8b6ffd 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -3427,7 +3427,7 @@ create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr
*step, locus *where,
gfc_namespace *ns, char *vname)
{
- char name[GFC_MAX_SYMBOL_LEN +1];
+ const char *name;
gfc_symtree *symtree;
gfc_symbol *symbol;
gfc_expr *i;
@@ -3435,9 +3435,9 @@ create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr
*step, locus *where,
/* Create an expression for the iteration variable. */
if (vname)
- sprintf (name, "__var_%d_do_%s", var_num++, vname);
+ name = gfc_get_string ("__var_%d_do_%s", var_num++, vname);
else
- sprintf (name, "__var_%d_do", var_num++);
+ name = gfc_get_string ("__var_%d_do", var_num++);
if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index f27249ec6ed..2c4d6e8228c 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -6048,7 +6048,7 @@ select_type_push (gfc_symbol *sel)
static gfc_symtree *
select_intrinsic_set_tmp (gfc_typespec *ts)
{
- char name[GFC_MAX_SYMBOL_LEN];
+ const char *name;
gfc_symtree *tmp;
HOST_WIDE_INT charlen = 0;
@@ -6064,10 +6064,10 @@ select_intrinsic_set_tmp (gfc_typespec *ts)
charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
if (ts->type != BT_CHARACTER)
- sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
+ name = gfc_get_string ("__tmp_%s_%d", gfc_basic_typename (ts->type),
ts->kind);
else
- snprintf (name, sizeof (name), "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
+ name = gfc_get_string ("__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
gfc_basic_typename (ts->type), charlen, ts->kind);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index afb745bddc5..e98e6a6d53e 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8842,7 +8842,7 @@ resolve_select_type (gfc_code *code, gfc_namespace
*old_ns)
gfc_code *class_is = NULL, *default_case = NULL;
gfc_case *c;
gfc_symtree *st;
- char name[GFC_MAX_SYMBOL_LEN];
+ const char *name;
gfc_namespace *ns;
int error = 0;
int rank = 0;
@@ -9096,21 +9096,20 @@ resolve_select_type (gfc_code *code, gfc_namespace
*old_ns)
'global' one). */
if (c->ts.type == BT_CLASS)
- sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
+ name = gfc_get_string ("__tmp_class_%s", c->ts.u.derived->name);
else if (c->ts.type == BT_DERIVED)
- sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
+ name = gfc_get_string ("__tmp_type_%s", c->ts.u.derived->name);
else if (c->ts.type == BT_CHARACTER)
{
HOST_WIDE_INT charlen = 0;
if (c->ts.u.cl && c->ts.u.cl->length
&& c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
- snprintf (name, sizeof (name),
- "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
+ name = gfc_get_string ("__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
}
else
- sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type),
+ name = gfc_get_string ("__tmp_%s_%d", gfc_basic_typename (c->ts.type),
c->ts.kind);
st = gfc_find_symtree (ns->sym_root, name);
@@ -9553,20 +9552,19 @@ resolve_critical (gfc_code *code)
{
gfc_symtree *symtree;
gfc_symbol *lock_type;
- char name[GFC_MAX_SYMBOL_LEN];
+ const char *name;
static int serial = 0;
if (flag_coarray != GFC_FCOARRAY_LIB)
return;
- symtree = gfc_find_symtree (gfc_current_ns->sym_root,
- GFC_PREFIX ("lock_type"));
+ name = gfc_get_string (GFC_PREFIX ("lock_type"));
+ symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
if (symtree)
lock_type = symtree->n.sym;
else
{
- if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree,
- false) != 0)
+ if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
gcc_unreachable ();
lock_type = symtree->n.sym;
lock_type->attr.flavor = FL_DERIVED;
@@ -9575,7 +9573,7 @@ resolve_critical (gfc_code *code)
lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE;
}
- sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++);
+ name = gfc_get_string (GFC_PREFIX ("lock_var") "%d", serial++);
if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
gcc_unreachable ();
@@ -10569,13 +10567,13 @@ static gfc_expr*
get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
{
static int serial = 0;
- char name[GFC_MAX_SYMBOL_LEN];
+ const char *name;
gfc_symtree *tmp;
gfc_array_spec *as;
gfc_array_ref *aref;
gfc_ref *ref;
- sprintf (name, GFC_PREFIX("DA%d"), serial++);
+ name = gfc_get_string (GFC_PREFIX("DA%d"), serial++);
gfc_get_sym_tree (name, ns, &tmp, false);
gfc_add_type (tmp->n.sym, &e->ts, NULL);
@@ -13956,9 +13954,9 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
&& !c->attr.function
&& !sym->attr.is_class)
{
- char name[GFC_MAX_SYMBOL_LEN+9];
+ const char *name;
gfc_component *strlen;
- sprintf (name, "_%s_length", c->name);
+ name = gfc_get_string ("_%s_length", c->name);
strlen = gfc_find_component (sym, name, true, true, NULL);
if (strlen == NULL)
{
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 6c8a5b30568..d502c127951 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -7307,7 +7307,7 @@ alloc_scalar_allocatable_for_subcomponent_assignment
(stmtblock_t *block,
if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
{
- char name[GFC_MAX_SYMBOL_LEN+9];
+ const char *name;
gfc_component *strlen;
/* Use the rhs string length and the lhs element size. */
gcc_assert (expr2->ts.type == BT_CHARACTER);
@@ -7321,7 +7321,7 @@ alloc_scalar_allocatable_for_subcomponent_assignment
(stmtblock_t *block,
/* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
component. */
- sprintf (name, "_%s_length", cm->name);
+ name = gfc_get_string ("_%s_length", cm->name);
strlen = gfc_find_component (sym, name, true, true, NULL);
lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
gfc_charlen_type_node,
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 153bab63396..66ba0572e0c 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -2330,14 +2330,14 @@ gfc_likely (tree cond, enum br_predictor predictor)
bool
gfc_deferred_strlen (gfc_component *c, tree *decl)
{
- char name[GFC_MAX_SYMBOL_LEN+9];
+ const char *name;
gfc_component *strlen;
if (!(c->ts.type == BT_CHARACTER
&& (c->ts.deferred || c->attr.pdt_string)))
return false;
- sprintf (name, "_%s_length", c->name);
+ name = gfc_get_string ("_%s_length", c->name);
for (strlen = c; strlen; strlen = strlen->next)
- if (strcmp (strlen->name, name) == 0)
+ if (strlen->name == name)
break;
*decl = strlen ? strlen->backend_decl : NULL_TREE;
return strlen != NULL;
--
2.19.0.rc1
