[gfortran, committed] Fix segfault in PR16336

[gfortran, committed] Fix segfault in PR16336

[Tobias Schlüter]

This patch which I commit under the obviously correct rule, fixes a bug
with error reporting: gfc_match_common used to call gfc_error with '%s'
in the format string, but no argument to go with that format item. D'oh.
I verified that the error message is now emitted correctly, and also
looked through match.c to find other omissions of the same type.

I'm inclined to believe that the code in PR 16336 is indeed invalid, but
I will double check the standard to make sure that this is true.

Built and tested on i686-pc-linux.

- Tobi

Index: ChangeLog
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/ChangeLog,v
retrieving revision 1.109
diff -u -p -r1.109 ChangeLog
--- ChangeLog   10 Jul 2004 12:45:33 -0000      1.109
+++ ChangeLog   10 Jul 2004 16:19:00 -0000
@@ -3,6 +3,9 @@
        * expr.c (gfc_check_pointer_assign): Verify that rank of the LHS
        and RHS match. Return early if the RHS is NULL().

+       PR fortran/16336
+       * match.c (match_common): Fix error reporting for used common.
+
 2004-07-10  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>

        * trans-common.c: Fix whitespace issues, make variable names
Index: match.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/match.c,v
retrieving revision 1.15
diff -u -p -r1.15 match.c
--- match.c     1 Jul 2004 07:50:18 -0000       1.15
+++ match.c     10 Jul 2004 16:19:00 -0000
@@ -2146,7 +2146,7 @@ gfc_match_common (void)
          if (t->use_assoc)
            {
              gfc_error ("COMMON block '%s' at %C has already "
-                        "been USE-associated");
+                        "been USE-associated", name);
              goto cleanup;
            }
        }

Re: [gfortran, committed] Fix segfault in PR16336

[Tobias Schlüter]

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.  */
> 

Re: [gfortran, committed] Fix segfault in PR16336

[Paul Brook]

> 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.

Ok, with minor nit below.

There are issues when you have multiple instances of the same common block. 
However these aren't any worse than when the same common block is used in 
multiple program units, so can be solved later.

Paul

> 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.

s/is set/is nonzero/