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

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

1 files changed, 50 insertions, 16 deletions

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index b2808d4..4e6c520 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);