From 7b2060ba65acd2fdcbf0dedd5ad0a268b2028b51 Mon Sep 17 00:00:00 2001 From: jb Date: Sun, 29 Jan 2012 17:19:32 +0000 Subject: [PATCH] PR 51808 Support arbitrarily long bind(C) binding labels. 2012-01-29 Janne Blomqvist 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 PR fortran/51808 * gfortran.dg/module_md5_1.f90: Update MD5 sum. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@183677 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 54 +++++++++++++++++++++++- gcc/fortran/decl.c | 56 ++++++++++++------------- gcc/fortran/gfortran.h | 5 +-- gcc/fortran/match.c | 47 +++++++++++---------- gcc/fortran/match.h | 3 +- gcc/fortran/module.c | 66 ++++++++++++++++++++++-------- gcc/fortran/resolve.c | 38 ++++++++--------- gcc/fortran/symbol.c | 15 ++++--- gcc/fortran/trans-common.c | 2 +- gcc/fortran/trans-decl.c | 7 ++-- gcc/testsuite/ChangeLog | 5 +++ gcc/testsuite/gfortran.dg/module_md5_1.f90 | 2 +- 12 files changed, 190 insertions(+), 110 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 42c228b8bc2..2d40e40ddf8 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,55 @@ +2012-01-29 Janne Blomqvist + + 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 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 PR fortran/51970 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 7f3fad2fe0a..0cfb0ef3831 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -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 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 23c16ba7745..bf9a1f9074b 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 05853081173..3024cc7b9c9 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -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. */ diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index c4e7e911d95..642c4373ac7 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 b2808d4d9d9..4e6c520bc97 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -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); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 250c9eb5cd6..30980d21b8b 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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) { diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 36fc1ed562b..e13e1df0d33 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -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); diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index 22aa3502dbd..dcc2176a246 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 8efe5a97bbc..cb8f613813e 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/ChangeLog b/gcc/testsuite/ChangeLog index 5ec0ccd29b9..39dd3a00f07 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2012-01-29 Janne Blomqvist + + PR fortran/51808 + * gfortran.dg/module_md5_1.f90: Update MD5 sum. + 2012-01-28 Tobias Burnus PR fortran/51972 diff --git a/gcc/testsuite/gfortran.dg/module_md5_1.f90 b/gcc/testsuite/gfortran.dg/module_md5_1.f90 index f146cd2e204..0816a7053f5 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" } } -- 2.11.0