FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

PR 51808 Support arbitrarily long bind(C) binding labels.

Browse source 
2012-01-29  Janne Blomqvist  <jb@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.
	(verify_bind_c_sym): Handle sym->binding_label being a pointer.
	(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): Don't set binding_label.
	(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): Don't set binding label.
	(generate_isocbinding_symbol): Insert binding_label into symbol
	table.
	(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-29  Janne Blomqvist  <jb@gcc.gnu.org>

	PR fortran/51808
	* gfortran.dg/module_md5_1.f90: Update MD5 sum.

From-SVN: r183677
This commit is contained in:
Janne Blomqvist 2012-01-29 19:19:32 +02:00
parent 9b850dd969
commit 62603fae93
12 changed files with 190 additions and 110 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

54
gcc/fortran/ChangeLog
View file

@ -1,3 +1,55 @@
2012-01-29 Janne Blomqvist <jb@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.
(verify_bind_c_sym): Handle sym->binding_label being a pointer.
(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): Don't set binding_label.
(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): Don't set binding label.
(generate_isocbinding_symbol): Insert binding_label into symbol
table.
(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.
2012-01-29 Tobias Burnus <burnus@net-b.de>
PR fortran/52038
@ -22,7 +74,7 @@
* resolve.c (resolve_formal_arglist): Fix elemental
constraint checks for polymorphic dummies also for
pointers.
2012-01-27 Tobias Burnus <burnus@net-b.de>
PR fortran/51970

56
gcc/fortran/decl.c
View file

@ -26,6 +26,7 @@ along with GCC; see the file COPYING3. If not see
#include "parse.h"
#include "flags.h"
#include "constructor.h"
#include "tree.h"
/* Macros to access allocate memory for gfc_data_variable,
gfc_data_value and gfc_data. */
@ -34,6 +35,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 +55,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 +1168,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;
}
@ -2575,7 +2579,7 @@ 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';
curr_binding_label = NULL;
if (gfc_match (" byte") == MATCH_YES)
{
@ -3803,8 +3807,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)
{
@ -3813,17 +3817,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 = 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 = IDENTIFIER_POINTER (get_identifier (sym_name));
}
return SUCCESS;
@ -4003,7 +4005,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 "
@ -4029,7 +4031,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;
@ -4046,7 +4048,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;
@ -4157,7 +4160,7 @@ 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';
curr_binding_label = NULL;
/* Look for the bind(c). */
found_match = gfc_match_bind_c (NULL, true);
@ -4865,7 +4868,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;
}
@ -5709,7 +5713,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;
@ -5717,10 +5721,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)
@ -5755,7 +5755,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. */
@ -5803,14 +5803,12 @@ 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);
curr_binding_label = binding_label;
}
else if (allow_binding_name)
{
@ -5819,7 +5817,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 = IDENTIFIER_POINTER (get_identifier (sym->name));
}
if (has_name_equals && gfc_current_state () == COMP_INTERFACE

5
gcc/fortran/gfortran.h
View file

@ -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;

47
gcc/fortran/match.c
View file

@ -1,6 +1,6 @@
/* Matching subroutines in all sizes, shapes and colors.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
2009, 2010, 2011
2009, 2010, 2011, 2012
Free Software Foundation, Inc.
Contributed by Andy Vaught
@ -26,6 +26,7 @@ along with GCC; see the file COPYING3. If not see
#include "gfortran.h"
#include "match.h"
#include "parse.h"
#include "tree.h"
int gfc_matching_ptr_assignment = 0;
int gfc_matching_procptr_assignment = 0;
@ -571,22 +572,22 @@ 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
that is matched. Return MATCH_ERROR if the name is too long
(though this is a self-imposed limit), MATCH_NO if what we're
seeing isn't a name, and MATCH_YES if we successfully match a C
name. */
that is matched. Return MATCH_ERROR if the name is not a valid C
name, MATCH_NO if what we're seeing isn't a name, and MATCH_YES if
we successfully match a C name. */
match
gfc_match_name_C (char *buffer)
gfc_match_name_C (char **buffer)
{
locus old_loc;
int i = 0;
size_t 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;
}
buf[i++] = (unsigned char) c;
if (i >= cursz)
{
cursz *= 2;
buf = XRESIZEVEC (char, buf, cursz);
}
old_loc = gfc_current_locus;
@ -636,7 +631,11 @@ gfc_match_name_C (char *buffer)
c = gfc_next_char_literal (INSTRING_WARN);
} while (ISALNUM (c) || c == '_');
buffer[i] = '\0';
/* The binding label will be needed later anyway, so just insert it
into the symbol table. */
buf[i] = '\0';
*buffer = IDENTIFIER_POINTER (get_identifier (buf));
XDELETEVEC (buf);
gfc_current_locus = old_loc;
/* See if we stopped because of whitespace. */

3
gcc/fortran/match.h
View file

@ -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);

66
gcc/fortran/module.c
View file

@ -75,6 +75,7 @@ along with GCC; see the file COPYING3. If not see
#include "md5.h"
#include "constructor.h"
#include "cpp.h"
#include "tree.h"
#define MODULE_EXTENSION ".mod"
@ -160,7 +161,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 +228,9 @@ free_pi_tree (pointer_info *p)
free_pi_tree (p->left);
free_pi_tree (p->right);
if (iomode == IO_INPUT)
XDELETEVEC (p->u.rsym.binding_label);
free (p);
}
@ -1812,6 +1816,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 +4151,7 @@ load_commons (void)
while (peek_atom () != ATOM_RPAREN)
{
int flags;
char* label;
mio_lparen ();
mio_internal_string (name);
@ -4142,7 +4168,10 @@ 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 = IDENTIFIER_POINTER (get_identifier (label));
XDELETEVEC (label);
mio_rparen ();
}
@ -4344,7 +4373,9 @@ 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);
if (p->u.rsym.binding_label)
sym->binding_label = IDENTIFIER_POINTER (get_identifier
(p->u.rsym.binding_label));
associate_integer_pointer (p, sym);
}
@ -4493,6 +4524,7 @@ read_module (void)
while (peek_atom () != ATOM_RPAREN)
{
char* bind_label;
require_atom (ATOM_INTEGER);
info = get_integer (atom_int);
@ -4501,8 +4533,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;
@ -4634,10 +4669,10 @@ 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);
if (info->u.rsym.binding_label)
sym->binding_label =
IDENTIFIER_POINTER (get_identifier
(info->u.rsym.binding_label));
}
st->n.sym = sym;
@ -4836,10 +4871,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;
@ -4924,9 +4959,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 ();
}
@ -5024,13 +5058,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);

38
gcc/fortran/resolve.c
View file

@ -2722,7 +2722,6 @@ 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];
int optional_arg = 0;
gfc_try retval = SUCCESS;
gfc_symbol *args_sym;
@ -2756,26 +2755,23 @@ 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);
optional_arg = 1;
}
else
{
/* one arg. */
sprintf (name, "%s_1", sym->name);
sprintf (binding_label, "%s_1", sym->binding_label);
optional_arg = 0;
}
/* Get a new symbol for the version of c_associated that
will get called. */
*new_sym = get_iso_c_sym (sym, name, binding_label, optional_arg);
*new_sym = get_iso_c_sym (sym, name, NULL, optional_arg);
}
else if (sym->intmod_sym_id == ISOCBINDING_LOC
|| 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)
@ -3360,7 +3356,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;
@ -3393,7 +3389,8 @@ 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);
*binding_label = gfc_get_string ("%s_%c%d", sym->binding_label, type,
kind);
}
else
{
@ -3401,7 +3398,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);
*binding_label = sym->binding_label;
}
return;
@ -3423,7 +3420,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;
@ -3434,7 +3431,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)
{
@ -9668,6 +9665,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. */
@ -9676,7 +9675,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));
@ -9688,17 +9687,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,
@ -9710,7 +9706,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 =
@ -9777,7 +9773,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;
@ -9828,8 +9824,8 @@ 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. */
sym->binding_label = NULL;
}
else if (bind_c_sym == NULL)
{

15
gcc/fortran/symbol.c
View file

@ -1,6 +1,6 @@
/* Maintain binary trees of symbols.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
2009, 2010, 2011
2009, 2010, 2011, 2012
Free Software Foundation, Inc.
Contributed by Andy Vaught
@ -2556,8 +2556,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;
@ -3805,8 +3803,8 @@ 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);
/* Since we never generate a call to this symbol, don't set the
binding_label. */
/* Set the c_address field of c_null_ptr and c_null_funptr to
the value of NULL. */
@ -4588,8 +4586,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. */
sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
c_interop_kinds_table[s].name);
tmp_sym->binding_label =
gfc_get_string ("%s_%s", mod_name,
c_interop_kinds_table[s].name);
tmp_sym->attr.is_iso_c = 1;
if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
tmp_sym->attr.subroutine = 1;
@ -4702,7 +4701,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);

2
gcc/fortran/trans-common.c
View file

@ -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)

7
gcc/fortran/trans-decl.c
View file

@ -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);

5
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,8 @@
2012-01-29 Janne Blomqvist <jb@gcc.gnu.org>
PR fortran/51808
* gfortran.dg/module_md5_1.f90: Update MD5 sum.
2012-01-28 Tobias Burnus <burnus@net-b.de>
PR fortran/51972

2
gcc/testsuite/gfortran.dg/module_md5_1.f90
View file

@ -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" } }