Re: [gfortran, committed] Fix segfault in PR16336

[Tobias Schlüter <tobias dot schlueter at physik dot uni-muenchen dot de>]

Forgot to add gcc-patches again.

- Tobi

> 
> 2004-07-10  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
> 	
> 	PR fortran/16336
> 	* decl.c (gfc_match_save): Use-associated common block
> 	doesn't collide.
> 	* gfortran.h (gfc_common_head): Add new field 'name'.
> 	Fix typo in comment after #endif.
> 	* match.c (gfc_get_common): Add new argument from_common,
> 	mangle name if flag is set, fill in new field in structure
> 	gfc_common_head.
> 	(match_common): Set new arg in call to gfc_get_common,
> 	use-associated common block doesn't collide.
> 	* match.h (gfc_get_common): Adapt prototype.
> 	* module.c (load_commons): Set new arg in call to
> 	gfc_get_common.
> 	* symbol.c (free_common_tree): New function.
> 	(gfc_free_namespace): Call new function.
> 	* trans-common.c (several functions): Remove argument
> 	'name', use name from gfc_common_head instead.
> 
> Index: decl.c
> ===================================================================
> RCS file: /cvs/gcc/gcc/gcc/fortran/decl.c,v
> retrieving revision 1.17
> diff -u -p -r1.17 decl.c
> --- decl.c      3 Jul 2004 23:25:45 -0000       1.17
> +++ decl.c      10 Jul 2004 20:51:28 -0000
> @@ -2699,14 +2699,7 @@ gfc_match_save (void)
>        if (m == MATCH_NO)
>         goto syntax;
> 
> -      c = gfc_get_common (n);
> -
> -      if (c->use_assoc)
> -       {
> -         gfc_error("COMMON block '%s' at %C is already USE associated", n);
> -         return MATCH_ERROR;
> -       }
> -
> +      c = gfc_get_common (n, 0);
>        c->saved = 1;
> 
>        gfc_current_ns->seen_save = 1;
> Index: gfortran.h
> ===================================================================
> RCS file: /cvs/gcc/gcc/gcc/fortran/gfortran.h,v
> retrieving revision 1.18
> diff -u -p -r1.18 gfortran.h
> --- gfortran.h  9 Jul 2004 21:20:49 -0000       1.18
> +++ gfortran.h  10 Jul 2004 20:51:39 -0000
> @@ -678,6 +678,7 @@ typedef struct
>  {
>    locus where;
>    int use_assoc, saved;
> +  char name[GFC_MAX_SYMBOL_LEN + 1];
>    gfc_symbol *head;
>  }
>  gfc_common_head;
> @@ -1697,4 +1698,4 @@ void gfc_show_namespace (gfc_namespace *
>  /* parse.c */
>  try gfc_parse_file (void);
> 
> -#endif /* GFC_GFC_H  */
> +#endif /* GCC_GFORTRAN_H  */
> Index: match.c
> ===================================================================
> RCS file: /cvs/gcc/gcc/gcc/fortran/match.c,v
> retrieving revision 1.16
> diff -u -p -r1.16 match.c
> --- match.c     10 Jul 2004 16:26:05 -0000      1.16
> +++ match.c     10 Jul 2004 20:51:39 -0000
> @@ -2049,22 +2049,38 @@ cleanup:
> 
> 
>  /* Given a name, return a pointer to the common head structure,
> -   creating it if it does not exist.
> +   creating it if it does not exist. If FROM_MODULE is set, we mangle
> +   the name so that it doesn't interfere with commons defined in the
> +   using namespace.
>     TODO: Add to global symbol tree.  */
> 
>  gfc_common_head *
> -gfc_get_common (char *name)
> +gfc_get_common (const char *name, int from_module)
>  {
>    gfc_symtree *st;
> +  static int serial = 0;
> +  char mangled_name[GFC_MAX_SYMBOL_LEN+1];
> 
> -  st = gfc_find_symtree (gfc_current_ns->common_root, name);
> -  if (st == NULL)
> -    st = gfc_new_symtree (&gfc_current_ns->common_root, name);
> +  if (from_module)
> +    {
> +      /* A use associated common block is only needed to correctly layout
> +        the variables it contains.  */
> +      snprintf(mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
> +      st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
> +    }
> +  else
> +    {
> +      st = gfc_find_symtree (gfc_current_ns->common_root, name);
> +
> +      if (st == NULL)
> +       st = gfc_new_symtree (&gfc_current_ns->common_root, name);
> +    }
> 
>    if (st->n.common == NULL)
>      {
>        st->n.common = gfc_get_common_head ();
>        st->n.common->where = gfc_current_locus;
> +      strcpy (st->n.common->name, name);
>      }
> 
>    return st->n.common;
> @@ -2140,15 +2156,8 @@ gfc_match_common (void)
>         }
>        else
>         {
> -         t = gfc_get_common (name);
> +         t = gfc_get_common (name, 0);
>           head = &t->head;
> -
> -         if (t->use_assoc)
> -           {
> -             gfc_error ("COMMON block '%s' at %C has already "
> -                        "been USE-associated", name);
> -             goto cleanup;
> -           }
>         }
> 
>        if (*head == NULL)
> Index: match.h
> ===================================================================
> RCS file: /cvs/gcc/gcc/gcc/fortran/match.h,v
> retrieving revision 1.8
> diff -u -p -r1.8 match.h
> --- match.h     30 Jun 2004 12:48:45 -0000      1.8
> +++ match.h     10 Jul 2004 20:51:39 -0000
> @@ -89,7 +89,7 @@ match gfc_match_forall (gfc_statement *)
> 
>  /* Other functions.  */
> 
> -gfc_common_head *gfc_get_common (char *);
> +gfc_common_head *gfc_get_common (const char *, int);
> 
>  /* decl.c */
> 
> Index: module.c
> ===================================================================
> RCS file: /cvs/gcc/gcc/gcc/fortran/module.c,v
> retrieving revision 1.10
> diff -u -p -r1.10 module.c
> --- module.c    9 Jul 2004 22:27:15 -0000       1.10
> +++ module.c    10 Jul 2004 20:51:48 -0000
> @@ -2825,7 +2825,7 @@ load_commons(void)
>        mio_lparen ();
>        mio_internal_string (name);
> 
> -      p = gfc_get_common (name);
> +      p = gfc_get_common (name, 1);
> 
>        mio_symbol_ref (&p->head);
>        mio_integer (&p->saved);
> Index: symbol.c
> ===================================================================
> RCS file: /cvs/gcc/gcc/gcc/fortran/symbol.c,v
> retrieving revision 1.9
> diff -u -p -r1.9 symbol.c
> --- symbol.c    3 Jul 2004 23:25:45 -0000       1.9
> +++ symbol.c    10 Jul 2004 20:51:48 -0000
> @@ -2139,6 +2139,22 @@ gfc_commit_symbols (void)
>  }
> 
> 
> +/* Recursive function that deletes an entire tree and all the common
> +   head structures it points to.  */
> +
> +static void
> +free_common_tree (gfc_symtree * common_tree)
> +{
> +  if (common_tree == NULL)
> +    return;
> +
> +  free_common_tree (common_tree->left);
> +  free_common_tree (common_tree->right);
> +
> +  gfc_free (common_tree);
> +}
> +
> +
>  /* Recursive function that deletes an entire tree and all the user
>     operator nodes that it contains.  */
> 
> @@ -2216,6 +2232,7 @@ gfc_free_namespace (gfc_namespace * ns)
> 
>    free_sym_tree (ns->sym_root);
>    free_uop_tree (ns->uop_root);
> +  free_common_tree (ns->common_root);
> 
>    for (cl = ns->cl_list; cl; cl = cl2)
>      {
> Index: trans-common.c
> ===================================================================
> RCS file: /cvs/gcc/gcc/gcc/fortran/trans-common.c,v
> retrieving revision 1.11
> diff -u -p -r1.11 trans-common.c
> --- trans-common.c      10 Jul 2004 11:21:42 -0000      1.11
> +++ trans-common.c      10 Jul 2004 20:51:53 -0000
> @@ -277,8 +277,7 @@ build_equiv_decl (tree union_type, bool
>  /* Get storage for common block.  */
> 
>  static tree
> -build_common_decl (gfc_common_head *com, const char *name,
> -                  tree union_type, bool is_init)
> +build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
>  {
>    gfc_symbol *common_sym;
>    tree decl;
> @@ -287,7 +286,7 @@ build_common_decl (gfc_common_head *com,
>    if (gfc_common_ns == NULL)
>      gfc_common_ns = gfc_get_namespace (NULL);
> 
> -  gfc_get_symbol (name, gfc_common_ns, &common_sym);
> +  gfc_get_symbol (com->name, gfc_common_ns, &common_sym);
>    decl = common_sym->backend_decl;
> 
>    /* Update the size of this common block as needed.  */
> @@ -299,9 +298,9 @@ build_common_decl (gfc_common_head *com,
>            /* Named common blocks of the same name shall be of the same size
>               in all scoping units of a program in which they appear, but
>               blank common blocks may be of different sizes.  */
> -          if (strcmp (name, BLANK_COMMON_NAME))
> +          if (strcmp (com->name, BLANK_COMMON_NAME))
>             gfc_warning ("Named COMMON block '%s' at %L shall be of the "
> -                        "same size", name, &com->where);
> +                        "same size", com->name, &com->where);
>            DECL_SIZE_UNIT (decl) = size;
>          }
>       }
> @@ -315,8 +314,8 @@ build_common_decl (gfc_common_head *com,
>    /* If there is no backend_decl for the common block, build it.  */
>    if (decl == NULL_TREE)
>      {
> -      decl = build_decl (VAR_DECL, get_identifier (name), union_type);
> -      SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (name));
> +      decl = build_decl (VAR_DECL, get_identifier (com->name), union_type);
> +      SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id
> (com->name));
>        TREE_PUBLIC (decl) = 1;
>        TREE_STATIC (decl) = 1;
>        DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
> @@ -348,7 +347,7 @@ build_common_decl (gfc_common_head *com,
>     backend declarations for all of the elements.  */
> 
>  static void
> -create_common (gfc_common_head *com, const char *name)
> +create_common (gfc_common_head *com)
>  {
>    segment_info *s, *next_s;
>    tree union_type;
> @@ -377,7 +376,7 @@ create_common (gfc_common_head *com, con
>    finish_record_layout (rli, true);
> 
>    if (com)
> -    decl = build_common_decl (com, name, union_type, is_init);
> +    decl = build_common_decl (com, union_type, is_init);
>    else
>      decl = build_equiv_decl (union_type, is_init);
> 
> @@ -720,7 +719,7 @@ add_equivalences (void)
>     and all of the symbols equivalenced with that symbol.  */
> 
>  static void
> -new_segment (gfc_common_head *common, const char *name, gfc_symbol *sym)
> +new_segment (gfc_common_head *common, gfc_symbol *sym)
>  {
> 
>    current_segment = get_segment_info (sym, current_offset);
> @@ -733,8 +732,9 @@ new_segment (gfc_common_head *common, co
>    add_equivalences ();
> 
>    if (current_segment->offset < 0)
> -    gfc_error ("The equivalence set for '%s' cause an invalid extension "
> -              "to COMMON '%s' at %L", sym->name, name, &common->where);
> +    gfc_error ("The equivalence set for '%s' cause an invalid "
> +              "extension to COMMON '%s' at %L", sym->name,
> +              common->name, &common->where);
> 
>    /* Add these to the common block.  */
>    current_common = add_segments (current_common, current_segment);
> @@ -770,7 +770,7 @@ finish_equivalences (gfc_namespace *ns)
>           v->offset -= min_offset;
> 
>          current_common = current_segment;
> -        create_common (NULL, NULL);
> +        create_common (NULL);
>          break;
>        }
>  }
> @@ -779,8 +779,7 @@ finish_equivalences (gfc_namespace *ns)
>  /* Translate a single common block.  */
> 
>  static void
> -translate_common (gfc_common_head *common, const char *name,
> -                 gfc_symbol *var_list)
> +translate_common (gfc_common_head *common, gfc_symbol *var_list)
>  {
>    gfc_symbol *sym;
> 
> @@ -791,10 +790,10 @@ translate_common (gfc_common_head *commo
>    for (sym = var_list; sym; sym = sym->common_next)
>      {
>        if (! sym->equiv_built)
> -       new_segment (common, name, sym);
> +       new_segment (common, sym);
>      }
> 
> -  create_common (common, name);
> +  create_common (common);
>  }
> 
> 
> @@ -804,7 +803,7 @@ static void
>  named_common (gfc_symtree *st)
>  {
> 
> -  translate_common (st->n.common, st->name, st->n.common->head);
> +  translate_common (st->n.common, st->n.common->head);
>  }
> 
> 
> @@ -821,7 +820,8 @@ gfc_trans_common (gfc_namespace *ns)
>    if (ns->blank_common.head != NULL)
>      {
>        c = gfc_get_common_head ();
> -      translate_common (c, BLANK_COMMON_NAME, ns->blank_common.head);
> +      strcpy (c->name, BLANK_COMMON_NAME);
> +      translate_common (c, ns->blank_common.head);
>      }
> 
>    /* Translate all named common blocks.  */
>