Hi,
the attached patch changes the binding labels that are needed for
bind(C) symbols to be heap allocated rather than, as currently, being
fixed size arrays of size 127 (or 64 in module.c!?). There are two
benefits of this:
1) For the vast majority of symbols which are not bind(C) symbols in a
typical Fortran program, we save some memory.
2) For bind(C) symbols with a non-default binding label, that is
bind(C, name="foo"), the label can be arbitrary long, subject to heap
memory limitations obviously. While Fortran limits names to be at most
63 characters, the binding label is not a Fortran name and the Fortran
standard places no limit on the length of it. Similarly, C99 merely
requires that the implementation must support identifiers containing
at least 31 characters, but allows implementations to support
arbitrarily long identifiers. The linker may also limit the maximum
symbol length, but C++ symbols containing over 4000 characters have
apparently been seen in real programs, so presumably linkers today can
handle quite long symbol names.
The extra malloc/free of course has a cost, but OTOH in some cases the
patch changes strcpy to mere pointer assignments. But to reiterate,
this matter only for those symbols which have a binding label.
The patch also changes the module format slightly, in that for symbols
without a binding label, an empty string is written instead of
repeating the name. AFAICS with the patch the compiler can still read
pre-patch .mod files, so I didn't bump the module version number.
Regtested on x86_64-unknown-linux-gnu, Ok for trunk/4.8? While the
patch is long, it's quite mechanical, but OTOH the issue it fixes
isn't particularly serious so I think waiting until 4.8 would be fine
as well. But I'll leave the decision to the reviewer(s) .
2012-01-13 Janne Blomqvist <j...@gcc.gnu.org>
PR fortran/51808
* decl.c (set_binding_label): Move prototype from match.h to here.
(curr_binding_label): Make a pointer rather than static array.
(build_sym): Check sym->binding_label pointer rather than array,
update set_binding_label call, handle curr_binding_label changes.
(set_binding_label): Handle new curr_binding_label, dest_label
double ptr, and sym->binding_label.
(set_verify_bind_c_sym): Check sym->binding_label pointer rather
than array, update set_binding_label call.
(gfc_match_bind_c_stmt): Handle curr_binding_label change.
(match_procedure_decl): Update set_binding_label call.
(gfc_match_bind_c): Change binding_label to pointer, update
gfc_match_name_C call.
* gfortran.h (GFC_MAX_BINDING_LABEL_LEN): Remove macro.
(gfc_symbol): Make binding_label a pointer.
(gfc_common_head): Likewise.
* match.c (gfc_match_name_C): Heap allocate bind(C) name.
* match.h (gfc_match_name_C): Change prototype argument.
(set_binding_label): Move prototype to decl.c.
* module.c (struct pointer_info): Make binding_label a pointer.
(free_pi_tree): Free unused binding_label.
(mio_read_string): New function.
(mio_write_string): New function.
(load_commons): Redo reading of binding_label.
(read_module): Likewise.
(write_common_0): Change to write empty string instead of name if
no binding_label.
(write_blank_common): Write empty string for binding label.
(write_symbol): Change to write empty string instead of name if no
binding_label.
* resolve.c (gfc_iso_c_func_interface): Make binding_label a
pointer.
(set_name_and_label): Make binding_label double pointer, use
asprintf.
(gfc_iso_c_sub_interface): Make binding_label a pointer.
(resolve_bind_c_comms): Handle cases if
gfc_common_head->binding_label is NULL.
(gfc_verify_binding_labels): sym->binding_label is a pointer.
* symbol.c (gfc_free_symbol): Free binding_label.
(gfc_new_symbol): Rely on XCNEW zero init for binding_label.
(gen_special_c_interop_ptr): Use asprintf.
(generate_isocbinding_symbol): Allocate space for binding_label.
(get_iso_c_sym): Use pointer assignment instead of strcpy.
* trans-common.c (gfc_sym_mangled_common_id): Handle
com->binding_label being a pointer.
* trans-decl.c (gfc_sym_mangled_identifier): Handle
sym->binding_label being a pointer.
(gfc_sym_mangled_function_id): Likewise.
testsuite ChangeLog
2012-01-13 Janne Blomqvist <j...@gcc.gnu.org>
PR fortran/51808
* gfortran.dg/module_md5_1.f90: Update MD5 sum.
--
Janne Blomqvist
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 3e553a3..724c8ad 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -34,6 +34,9 @@ along with GCC; see the file COPYING3. If not see
#define gfc_get_data() XCNEW (gfc_data)
+static gfc_try set_binding_label (char **, const char *, int);
+
+
/* This flag is set if an old-style length selector is matched
during a type-declaration statement. */
@@ -51,7 +54,7 @@ static gfc_array_spec *current_as;
static int colon_seen;
/* The current binding label (if any). */
-static char curr_binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+static char* curr_binding_label;
/* Need to know how many identifiers are on the current data declaration
line in case we're given the BIND(C) attribute with a NAME= specifier. */
static int num_idents_on_line;
@@ -1164,11 +1167,11 @@ build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
with a bind(c) and make sure the binding label is set correctly. */
if (sym->attr.is_bind_c == 1)
{
- if (sym->binding_label[0] == '\0')
+ if (!sym->binding_label)
{
/* Set the binding label and verify that if a NAME= was specified
then only one identifier was in the entity-decl-list. */
- if (set_binding_label (sym->binding_label, sym->name,
+ if (set_binding_label (&sym->binding_label, sym->name,
num_idents_on_line) == FAILURE)
return FAILURE;
}
@@ -2521,7 +2524,8 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
ts->kind = -1;
/* Clear the current binding label, in case one is given. */
- curr_binding_label[0] = '\0';
+ XDELETEVEC (curr_binding_label);
+ curr_binding_label = NULL;
if (gfc_match (" byte") == MATCH_YES)
{
@@ -3749,8 +3753,8 @@ cleanup:
(J3/04-007, section 15.4.1). If a binding label was given and
there is more than one argument (num_idents), it is an error. */
-gfc_try
-set_binding_label (char *dest_label, const char *sym_name, int num_idents)
+static gfc_try
+set_binding_label (char **dest_label, const char *sym_name, int num_idents)
{
if (num_idents > 1 && has_name_equals)
{
@@ -3759,17 +3763,15 @@ set_binding_label (char *dest_label, const char *sym_name, int num_idents)
return FAILURE;
}
- if (curr_binding_label[0] != '\0')
- {
- /* Binding label given; store in temp holder til have sym. */
- strcpy (dest_label, curr_binding_label);
- }
+ if (curr_binding_label)
+ /* Binding label given; store in temp holder til have sym. */
+ *dest_label = xstrdup (curr_binding_label);
else
{
/* No binding label given, and the NAME= specifier did not exist,
which means there was no NAME="". */
if (sym_name != NULL && has_name_equals == 0)
- strcpy (dest_label, sym_name);
+ *dest_label = xstrdup (sym_name);
}
return SUCCESS;
@@ -3949,7 +3951,7 @@ verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
/* See if the symbol has been marked as private. If it has, make sure
there is no binding label and warn the user if there is one. */
if (tmp_sym->attr.access == ACCESS_PRIVATE
- && tmp_sym->binding_label[0] != '\0')
+ && tmp_sym->binding_label)
/* Use gfc_warning_now because we won't say that the symbol fails
just because of this. */
gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
@@ -3975,7 +3977,7 @@ set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
/* Set the is_bind_c bit in symbol_attribute. */
gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
- if (set_binding_label (tmp_sym->binding_label, tmp_sym->name,
+ if (set_binding_label (&tmp_sym->binding_label, tmp_sym->name,
num_idents) != SUCCESS)
return FAILURE;
@@ -3992,7 +3994,8 @@ set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
gfc_try retval = SUCCESS;
/* destLabel, common name, typespec (which may have binding label). */
- if (set_binding_label (com_block->binding_label, com_block->name, num_idents)
+ if (set_binding_label (&com_block->binding_label, com_block->name,
+ num_idents)
!= SUCCESS)
return FAILURE;
@@ -4103,7 +4106,8 @@ gfc_match_bind_c_stmt (void)
/* This may not be necessary. */
gfc_clear_ts (ts);
/* Clear the temporary binding label holder. */
- curr_binding_label[0] = '\0';
+ XDELETEVEC (curr_binding_label);
+ curr_binding_label = NULL;
/* Look for the bind(c). */
found_match = gfc_match_bind_c (NULL, true);
@@ -4811,7 +4815,8 @@ match_procedure_decl (void)
return MATCH_ERROR;
}
/* Set binding label for BIND(C). */
- if (set_binding_label (sym->binding_label, sym->name, num) != SUCCESS)
+ if (set_binding_label (&sym->binding_label, sym->name, num)
+ != SUCCESS)
return MATCH_ERROR;
}
@@ -5655,7 +5660,7 @@ match
gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
{
/* binding label, if exists */
- char binding_label[GFC_MAX_SYMBOL_LEN + 1];
+ char* binding_label = NULL;
match double_quote;
match single_quote;
@@ -5663,10 +5668,6 @@ gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
specifier or not. */
has_name_equals = 0;
- /* Init the first char to nil so we can catch if we don't have
- the label (name attr) or the symbol name yet. */
- binding_label[0] = '\0';
-
/* This much we have to be able to match, in this order, if
there is a bind(c) label. */
if (gfc_match (" bind ( c ") != MATCH_YES)
@@ -5701,7 +5702,7 @@ gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
/* Grab the binding label, using functions that will not lower
case the names automatically. */
- if (gfc_match_name_C (binding_label) != MATCH_YES)
+ if (gfc_match_name_C (&binding_label) != MATCH_YES)
return MATCH_ERROR;
/* Get the closing quotation. */
@@ -5749,14 +5750,15 @@ gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
/* Save the binding label to the symbol. If sym is null, we're
probably matching the typespec attributes of a declaration and
haven't gotten the name yet, and therefore, no symbol yet. */
- if (binding_label[0] != '\0')
+ if (binding_label)
{
if (sym != NULL)
- {
- strcpy (sym->binding_label, binding_label);
- }
+ sym->binding_label = binding_label;
else
- strcpy (curr_binding_label, binding_label);
+ {
+ XDELETEVEC (curr_binding_label);
+ curr_binding_label = binding_label;
+ }
}
else if (allow_binding_name)
{
@@ -5765,7 +5767,7 @@ gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
If name="" or allow_binding_name is false, no C binding name is
created. */
if (sym != NULL && sym->name != NULL && has_name_equals == 0)
- strncpy (sym->binding_label, sym->name, strlen (sym->name) + 1);
+ sym->binding_label = xstrdup (sym->name);
}
if (has_name_equals && gfc_current_state () == COMP_INTERFACE
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index f339271..358fe53 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -42,7 +42,6 @@ along with GCC; see the file COPYING3. If not see
/* Major control parameters. */
#define GFC_MAX_SYMBOL_LEN 63 /* Must be at least 63 for F2003. */
-#define GFC_MAX_BINDING_LABEL_LEN 126 /* (2 * GFC_MAX_SYMBOL_LEN) */
#define GFC_MAX_LINE 132 /* Characters beyond this are not seen. */
#define GFC_LETTERS 26 /* Number of letters in the alphabet. */
@@ -1238,7 +1237,7 @@ typedef struct gfc_symbol
/* This may be repetitive, since the typespec now has a binding
label field. */
- char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+ char* binding_label;
/* Store a reference to the common_block, if this symbol is in one. */
struct gfc_common_head *common_block;
@@ -1255,7 +1254,7 @@ typedef struct gfc_common_head
char use_assoc, saved, threadprivate;
char name[GFC_MAX_SYMBOL_LEN + 1];
struct gfc_symbol *head;
- char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+ char* binding_label;
int is_bind_c;
}
gfc_common_head;
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index fd91921..5f1b5eb 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -571,8 +571,7 @@ gfc_match_name (char *buffer)
/* Match a valid name for C, which is almost the same as for Fortran,
except that you can start with an underscore, etc.. It could have
been done by modifying the gfc_match_name, but this way other
- things C allows can be added, such as no limits on the length.
- Right now, the length is limited to the same thing as Fortran..
+ things C allows can be done, such as no limits on the length.
Also, by rewriting it, we use the gfc_next_char_C() to prevent the
input characters from being automatically lower cased, since C is
case sensitive. The parameter, buffer, is used to return the name
@@ -582,11 +581,13 @@ gfc_match_name (char *buffer)
name. */
match
-gfc_match_name_C (char *buffer)
+gfc_match_name_C (char **buffer)
{
locus old_loc;
int i = 0;
gfc_char_t c;
+ char* buf;
+ size_t cursz = 16;
old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
@@ -600,7 +601,6 @@ gfc_match_name_C (char *buffer)
symbol name, all lowercase. */
if (c == '"' || c == '\'')
{
- buffer[0] = '\0';
gfc_current_locus = old_loc;
return MATCH_YES;
}
@@ -611,24 +611,19 @@ gfc_match_name_C (char *buffer)
return MATCH_ERROR;
}
+ buf = XNEWVEC (char, cursz);
/* Continue to read valid variable name characters. */
do
{
gcc_assert (gfc_wide_fits_in_byte (c));
- buffer[i++] = (unsigned char) c;
-
- /* C does not define a maximum length of variable names, to my
- knowledge, but the compiler typically places a limit on them.
- For now, i'll use the same as the fortran limit for simplicity,
- but this may need to be changed to a dynamic buffer that can
- be realloc'ed here if necessary, or more likely, a larger
- upper-bound set. */
- if (i > gfc_option.max_identifier_length)
- {
- gfc_error ("Name at %C is too long");
- return MATCH_ERROR;
- }
+ if (i >= cursz)
+ {
+ cursz *= 2;
+ buf = XRESIZEVEC (char, buf, cursz);
+ }
+
+ buf[i++] = (unsigned char) c;
old_loc = gfc_current_locus;
@@ -636,7 +631,9 @@ gfc_match_name_C (char *buffer)
c = gfc_next_char_literal (INSTRING_WARN);
} while (ISALNUM (c) || c == '_');
- buffer[i] = '\0';
+ buf = XRESIZEVEC (char, buf, i + 1);
+ buf[i] = '\0';
+ *buffer = buf;
gfc_current_locus = old_loc;
/* See if we stopped because of whitespace. */
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index c4e7e91..642c437 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -52,7 +52,7 @@ match gfc_match_label (void);
match gfc_match_small_int (int *);
match gfc_match_small_int_expr (int *, gfc_expr **);
match gfc_match_name (char *);
-match gfc_match_name_C (char *buffer);
+match gfc_match_name_C (char **buffer);
match gfc_match_symbol (gfc_symbol **, int);
match gfc_match_sym_tree (gfc_symtree **, int);
match gfc_match_intrinsic_op (gfc_intrinsic_op *);
@@ -196,7 +196,6 @@ match gfc_match_volatile (void);
/* Fortran 2003 c interop.
TODO: some of these should be moved to another file rather than decl.c */
void set_com_block_bind_c (gfc_common_head *, int);
-gfc_try set_binding_label (char *, const char *, int);
gfc_try set_verify_bind_c_sym (gfc_symbol *, int);
gfc_try set_verify_bind_c_com_block (gfc_common_head *, int);
gfc_try get_bind_c_idents (void);
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index a681325..6c4a7c1 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -160,7 +160,7 @@ typedef struct pointer_info
module_locus where;
fixup_t *stfixup;
gfc_symtree *symtree;
- char binding_label[GFC_MAX_SYMBOL_LEN + 1];
+ char* binding_label;
}
rsym;
@@ -227,6 +227,9 @@ free_pi_tree (pointer_info *p)
free_pi_tree (p->left);
free_pi_tree (p->right);
+ if (iomode == IO_INPUT && p->u.rsym.state == UNUSED)
+ XDELETEVEC (p->u.rsym.binding_label);
+
free (p);
}
@@ -1812,6 +1815,27 @@ mio_internal_string (char *string)
}
+/* Read a string. The caller is responsible for freeing. */
+
+static char*
+mio_read_string (void)
+{
+ char* p;
+ require_atom (ATOM_STRING);
+ p = atom_string;
+ atom_string = NULL;
+ return p;
+}
+
+
+/* Write a string. */
+static void
+mio_write_string (const char* string)
+{
+ write_atom (ATOM_STRING, string);
+}
+
+
typedef enum
{ AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
@@ -4126,6 +4150,7 @@ load_commons (void)
while (peek_atom () != ATOM_RPAREN)
{
int flags;
+ char* label;
mio_lparen ();
mio_internal_string (name);
@@ -4142,7 +4167,11 @@ load_commons (void)
/* Get whether this was a bind(c) common or not. */
mio_integer (&p->is_bind_c);
/* Get the binding label. */
- mio_internal_string (p->binding_label);
+ label = mio_read_string ();
+ if (strlen (label))
+ p->binding_label = label;
+ else
+ XDELETEVEC (label);
mio_rparen ();
}
@@ -4344,7 +4373,7 @@ load_needed (pointer_info *p)
sym = gfc_new_symbol (p->u.rsym.true_name, ns);
sym->name = dt_lower_string (p->u.rsym.true_name);
sym->module = gfc_get_string (p->u.rsym.module);
- strcpy (sym->binding_label, p->u.rsym.binding_label);
+ sym->binding_label = p->u.rsym.binding_label;
associate_integer_pointer (p, sym);
}
@@ -4489,6 +4518,7 @@ read_module (void)
while (peek_atom () != ATOM_RPAREN)
{
+ char* bind_label;
require_atom (ATOM_INTEGER);
info = get_integer (atom_int);
@@ -4497,8 +4527,11 @@ read_module (void)
mio_internal_string (info->u.rsym.true_name);
mio_internal_string (info->u.rsym.module);
- mio_internal_string (info->u.rsym.binding_label);
-
+ bind_label = mio_read_string ();
+ if (strlen (bind_label))
+ info->u.rsym.binding_label = bind_label;
+ else
+ XDELETEVEC (bind_label);
require_atom (ATOM_INTEGER);
info->u.rsym.ns = atom_int;
@@ -4629,10 +4662,7 @@ read_module (void)
sym = info->u.rsym.sym;
sym->module = gfc_get_string (info->u.rsym.module);
- /* TODO: hmm, can we test this? Do we know it will be
- initialized to zeros? */
- if (info->u.rsym.binding_label[0] != '\0')
- strcpy (sym->binding_label, info->u.rsym.binding_label);
+ sym->binding_label = info->u.rsym.binding_label;
}
st->n.sym = sym;
@@ -4826,10 +4856,10 @@ write_common_0 (gfc_symtree *st, bool this_module)
write_common_0 (st->left, this_module);
- /* We will write out the binding label, or the name if no label given. */
+ /* We will write out the binding label, or "" if no label given. */
name = st->n.common->name;
p = st->n.common;
- label = p->is_bind_c ? p->binding_label : p->name;
+ label = (p->is_bind_c && p->binding_label) ? p->binding_label : "";
/* Check if we've already output this common. */
w = written_commons;
@@ -4914,9 +4944,8 @@ write_blank_common (void)
/* Write out whether the common block is bind(c) or not. */
mio_integer (&is_bind_c);
- /* Write out the binding label, which is BLANK_COMMON_NAME, though
- it doesn't matter because the label isn't used. */
- mio_pool_string (&name);
+ /* Write out an empty binding label. */
+ mio_write_string ("");
mio_rparen ();
}
@@ -5014,13 +5043,13 @@ write_symbol (int n, gfc_symbol *sym)
mio_pool_string (&sym->name);
mio_pool_string (&sym->module);
- if (sym->attr.is_bind_c || sym->attr.is_iso_c)
+ if ((sym->attr.is_bind_c || sym->attr.is_iso_c) && sym->binding_label)
{
label = sym->binding_label;
mio_pool_string (&label);
}
else
- mio_pool_string (&sym->name);
+ mio_write_string ("");
mio_pointer_ref (&sym->ns);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 7f476b8..219e10f 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2710,7 +2710,7 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
gfc_symbol **new_sym)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
- char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+ char* binding_label = NULL;
int optional_arg = 0;
gfc_try retval = SUCCESS;
gfc_symbol *args_sym;
@@ -2736,6 +2736,9 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
+ if (sym->binding_label)
+ binding_label = XNEWVEC (char, strlen (sym->binding_label) + 3);
+
/* If the user gave two args then they are providing something for
the optional arg (the second cptr). Therefore, set the name and
binding label to the c_associated for two cptrs. Otherwise,
@@ -2744,14 +2747,16 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
{
/* two args. */
sprintf (name, "%s_2", sym->name);
- sprintf (binding_label, "%s_2", sym->binding_label);
+ if (sym->binding_label)
+ sprintf (binding_label, "%s_2", sym->binding_label);
optional_arg = 1;
}
else
{
/* one arg. */
sprintf (name, "%s_1", sym->name);
- sprintf (binding_label, "%s_1", sym->binding_label);
+ if (sym->binding_label)
+ sprintf (binding_label, "%s_1", sym->binding_label);
optional_arg = 0;
}
@@ -2763,7 +2768,6 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
|| sym->intmod_sym_id == ISOCBINDING_FUNLOC)
{
sprintf (name, "%s", sym->name);
- sprintf (binding_label, "%s", sym->binding_label);
/* Error check the call. */
if (args->next != NULL)
@@ -3348,7 +3352,7 @@ generic:
static void
set_name_and_label (gfc_code *c, gfc_symbol *sym,
- char *name, char *binding_label)
+ char *name, char **binding_label)
{
gfc_expr *arg = NULL;
char type;
@@ -3381,7 +3385,7 @@ set_name_and_label (gfc_code *c, gfc_symbol *sym,
sprintf (name, "%s_%c%d", sym->name, type, kind);
/* Set up the binding label as the given symbol's label plus
the type and kind. */
- sprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
+ asprintf (binding_label, "%s_%c%d", sym->binding_label, type, kind);
}
else
{
@@ -3389,7 +3393,7 @@ set_name_and_label (gfc_code *c, gfc_symbol *sym,
was, cause it should at least be found, and the missing
arg error will be caught by compare_parameters(). */
sprintf (name, "%s", sym->name);
- sprintf (binding_label, "%s", sym->binding_label);
+ asprintf (binding_label, "%s", sym->binding_label);
}
return;
@@ -3411,7 +3415,7 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
gfc_symbol *new_sym;
/* this is fine, since we know the names won't use the max */
char name[GFC_MAX_SYMBOL_LEN + 1];
- char binding_label[GFC_MAX_BINDING_LABEL_LEN + 1];
+ char* binding_label;
/* default to success; will override if find error */
match m = MATCH_YES;
@@ -3422,7 +3426,7 @@ gfc_iso_c_sub_interface (gfc_code *c, gfc_symbol *sym)
if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
(sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
{
- set_name_and_label (c, sym, name, binding_label);
+ set_name_and_label (c, sym, name, &binding_label);
if (sym->intmod_sym_id == ISOCBINDING_F_POINTER)
{
@@ -9664,6 +9668,8 @@ resolve_bind_c_comms (gfc_symtree *comm_block_tree)
{
gfc_gsymbol *binding_label_gsym;
gfc_gsymbol *comm_name_gsym;
+ const char * bind_label = comm_block_tree->n.common->binding_label
+ ? comm_block_tree->n.common->binding_label : "";
/* See if a global symbol exists by the common block's name. It may
be NULL if the common block is use-associated. */
@@ -9672,7 +9678,7 @@ resolve_bind_c_comms (gfc_symtree *comm_block_tree)
if (comm_name_gsym != NULL && comm_name_gsym->type != GSYM_COMMON)
gfc_error ("Binding label '%s' for common block '%s' at %L collides "
"with the global entity '%s' at %L",
- comm_block_tree->n.common->binding_label,
+ bind_label,
comm_block_tree->n.common->name,
&(comm_block_tree->n.common->where),
comm_name_gsym->name, &(comm_name_gsym->where));
@@ -9684,17 +9690,14 @@ resolve_bind_c_comms (gfc_symtree *comm_block_tree)
as expected. */
if (comm_name_gsym->binding_label == NULL)
/* No binding label for common block stored yet; save this one. */
- comm_name_gsym->binding_label =
- comm_block_tree->n.common->binding_label;
- else
- if (strcmp (comm_name_gsym->binding_label,
- comm_block_tree->n.common->binding_label) != 0)
+ comm_name_gsym->binding_label = bind_label;
+ else if (strcmp (comm_name_gsym->binding_label, bind_label) != 0)
{
/* Common block names match but binding labels do not. */
gfc_error ("Binding label '%s' for common block '%s' at %L "
"does not match the binding label '%s' for common "
"block '%s' at %L",
- comm_block_tree->n.common->binding_label,
+ bind_label,
comm_block_tree->n.common->name,
&(comm_block_tree->n.common->where),
comm_name_gsym->binding_label,
@@ -9706,7 +9709,7 @@ resolve_bind_c_comms (gfc_symtree *comm_block_tree)
/* There is no binding label (NAME="") so we have nothing further to
check and nothing to add as a global symbol for the label. */
- if (comm_block_tree->n.common->binding_label[0] == '\0' )
+ if (!comm_block_tree->n.common->binding_label)
return;
binding_label_gsym =
@@ -9773,7 +9776,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)
int has_error = 0;
if (sym != NULL && sym->attr.is_bind_c && sym->attr.is_iso_c == 0
- && sym->attr.flavor != FL_DERIVED && sym->binding_label[0] != '\0')
+ && sym->attr.flavor != FL_DERIVED && sym->binding_label)
{
gfc_gsymbol *bind_c_sym;
@@ -9824,8 +9827,11 @@ gfc_verify_binding_labels (gfc_symbol *sym)
}
if (has_error != 0)
- /* Clear the binding label to prevent checking multiple times. */
- sym->binding_label[0] = '\0';
+ {
+ /* Clear the binding label to prevent checking multiple times. */
+ XDELETEVEC (sym->binding_label);
+ sym->binding_label = NULL;
+ }
}
else if (bind_c_sym == NULL)
{
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index fcc1ccf..087ce73 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2500,6 +2500,8 @@ gfc_free_symbol (gfc_symbol *sym)
gfc_free_namespace (sym->f2k_derived);
+ XDELETEVEC (sym->binding_label);
+
free (sym);
}
@@ -2553,8 +2555,6 @@ gfc_new_symbol (const char *name, gfc_namespace *ns)
/* Make sure flags for symbol being C bound are clear initially. */
p->attr.is_bind_c = 0;
p->attr.is_iso_c = 0;
- /* Make sure the binding label field has a Nul char to start. */
- p->binding_label[0] = '\0';
/* Clear the ptrs we may need. */
p->common_block = NULL;
@@ -3803,7 +3803,7 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
tmp_sym->attr.use_assoc = 1;
tmp_sym->attr.is_bind_c = 1;
/* Set the binding_label. */
- sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
+ asprintf (&tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
/* Set the c_address field of c_null_ptr and c_null_funptr to
the value of NULL. */
@@ -4585,6 +4585,9 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
/* Use the procedure's name as it is in the iso_c_binding module for
setting the binding label in case the user renamed the symbol. */
+ tmp_sym->binding_label
+ = XNEWVEC (char, strlen (mod_name)
+ + strlen (c_interop_kinds_table[s].name) + 2);
sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
c_interop_kinds_table[s].name);
tmp_sym->attr.is_iso_c = 1;
@@ -4699,7 +4702,7 @@ get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
"symtree for '%s'", new_name);
/* Now fill in the fields of the resolved symbol with the old sym. */
- strcpy (new_symtree->n.sym->binding_label, new_binding_label);
+ new_symtree->n.sym->binding_label = new_binding_label;
new_symtree->n.sym->attr = old_sym->attr;
new_symtree->n.sym->ts = old_sym->ts;
new_symtree->n.sym->module = gfc_get_string (old_sym->module);
diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c
index 22aa350..dcc2176 100644
--- a/gcc/fortran/trans-common.c
+++ b/gcc/fortran/trans-common.c
@@ -244,7 +244,7 @@ gfc_sym_mangled_common_id (gfc_common_head *com)
strcpy (name, com->name);
/* If we're suppose to do a bind(c). */
- if (com->is_bind_c == 1 && com->binding_label[0] != '\0')
+ if (com->is_bind_c == 1 && com->binding_label)
return get_identifier (com->binding_label);
if (strcmp (name, BLANK_COMMON_NAME) == 0)
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 0761ebb..400499c 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -326,9 +326,8 @@ gfc_sym_mangled_identifier (gfc_symbol * sym)
/* Prevent the mangling of identifiers that have an assigned
binding label (mainly those that are bind(c)). */
- if (sym->attr.is_bind_c == 1
- && sym->binding_label[0] != '\0')
- return get_identifier(sym->binding_label);
+ if (sym->attr.is_bind_c == 1 && sym->binding_label)
+ return get_identifier (sym->binding_label);
if (sym->module == NULL)
return gfc_sym_identifier (sym);
@@ -352,7 +351,7 @@ gfc_sym_mangled_function_id (gfc_symbol * sym)
provided, and remove the other checks. Then we could use it
for other things if we wished. */
if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
- sym->binding_label[0] != '\0')
+ sym->binding_label)
/* use the binding label rather than the mangled name */
return get_identifier (sym->binding_label);
diff --git a/gcc/testsuite/gfortran.dg/module_md5_1.f90 b/gcc/testsuite/gfortran.dg/module_md5_1.f90
index f146cd2..0816a70 100644
--- a/gcc/testsuite/gfortran.dg/module_md5_1.f90
+++ b/gcc/testsuite/gfortran.dg/module_md5_1.f90
@@ -10,5 +10,5 @@ program test
use foo
print *, pi
end program test
-! { dg-final { scan-module "foo" "MD5:12a205c48fe46315a609823f15986377" } }
+! { dg-final { scan-module "foo" "MD5:510304affe70481794fecdb22fc9ca0c" } }
! { dg-final { cleanup-modules "foo" } }
