Re: [gfortran] Patch: Fix PR 13415

[Paul Brook <paul at codesourcery dot com>]

On Friday 09 July 2004 20:52, Tobias Schlüter wrote:
> PR 13415 was a problem with array pointers in common blocks: we failed
> when trying to calculate the array size, when in fact we should have
> been storing the array descriptor.

You've tripped over another of the rules I forgot to document:
Calling gfc_sym_type multiple times for the same symbol is generally a bad 
idea. I think it's safe in this case, but it's definitely wasteful.

I changed the patch to remember and reuse the field type, rearranging a bit of 
code in the process.

Tested on i686-linux. Applied to mainline.

> Built and tested on i686-pc-linux. Since the original code had some
> reminiscences of its origin in g95, there are whitespace changes in the
> patch, I also changed the variable names to something more expressive.
>
> trans-common.c is in fact full of trailing whitespace, which I will
> remove in a follow-up patch, and, if people agree, I will change some
> variable names to something more expressive also in other functions.
> Since I won't be intermingling those changes with functional changes
> those changes shouldn't hurt.

Ok.

Paul

2004-07-10 Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
	Paul Brook  <paul@codesourcery.com>

	PR fortran/13415
	* trans-common.c (calculate_length): Remove ...
	(get_segment_info): Merge into here.  Save field type.
	(build_field): Use saved type.
	(create_common, new_condition, new_segment, finish_equivalences):
	Use new get_segment_info.
	* trans-types.c: Update comment.
testsuite
	* gfortran.dg/common_pointer_1.f90: New test.

Index: trans-common.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-common.c,v
retrieving revision 1.9
diff -u -p -r1.9 trans-common.c
--- trans-common.c	29 Jun 2004 22:11:38 -0000	1.9
+++ trans-common.c	10 Jul 2004 01:58:48 -0000
@@ -106,11 +106,13 @@ Software Foundation, 59 Temple Place - S
 #include <assert.h>
 
 
+/* Holds a single variable in a equivalence set.  */
 typedef struct segment_info
 {
   gfc_symbol *sym;
   HOST_WIDE_INT offset;
   HOST_WIDE_INT length;
+  /* This will contain the field type until the field is created.  */
   tree field; 
   struct segment_info *next;
 } segment_info;
@@ -119,11 +121,31 @@ static segment_info *current_segment, *c
 static HOST_WIDE_INT current_offset;
 static gfc_namespace *gfc_common_ns = NULL;
 
-#define get_segment_info() gfc_getmem (sizeof (segment_info))
-
 #define BLANK_COMMON_NAME "__BLNK__"
 
 
+/* Make a segment_info based on a symbol.  */
+
+static segment_info *
+get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
+{
+  segment_info *s;
+
+  /* Make sure we've got the character length.  */
+  if (sym->ts.type == BT_CHARACTER)
+    gfc_conv_const_charlen (sym->ts.cl);
+
+  /* Create the segment_info and fill it in.  */
+  s = (segment_info *) gfc_getmem (sizeof (segment_info));
+  s->sym = sym;
+  /* We will use this type when building the segment aggreagate type.  */
+  s->field = gfc_sym_type (sym);
+  s->length = int_size_in_bytes (s->field);
+  s->offset = offset;
+
+  return s;
+}
+
 /* Add combine segment V and segement LIST.  */
 
 static segment_info *
@@ -189,18 +211,19 @@ gfc_sym_mangled_common_id (const char  *
 }
 
 
-/* Build a filed declaration for a common variable or a local equivalence
+/* Build a field declaration for a common variable or a local equivalence
    object.  */
 
-static tree
+static void
 build_field (segment_info *h, tree union_type, record_layout_info rli)
 {
-  tree type = gfc_sym_type (h->sym);
-  tree name = get_identifier (h->sym->name);
-  tree field = build_decl (FIELD_DECL, name, type);
+  tree field;
+  tree name;
   HOST_WIDE_INT offset = h->offset;
   unsigned HOST_WIDE_INT desired_align, known_align;
 
+  name = get_identifier (h->sym->name);
+  field = build_decl (FIELD_DECL, name, h->field);
   known_align = (offset & -offset) * BITS_PER_UNIT;
   if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
     known_align = BIGGEST_ALIGNMENT;
@@ -218,7 +241,7 @@ build_field (segment_info *h, tree union
                             size_binop (PLUS_EXPR,
                                         DECL_FIELD_OFFSET (field),
                                         DECL_SIZE_UNIT (field)));
-  return field;
+  h->field = field;
 }
 
 
@@ -340,13 +363,12 @@ create_common (gfc_common_head *com, con
 
   for (h = current_common; h; h = next_s)
     {
-      tree field;
-      field = build_field (h, union_type, rli);
+      build_field (h, union_type, rli);
 
       /* Link the field into the type.  */
-      *field_link = field;
-      field_link = &TREE_CHAIN (field);
-      h->field = field;
+      *field_link = h->field;
+      field_link = &TREE_CHAIN (h->field);
+
       /* Has initial value.  */      
       if (h->sym->value)
         is_init = true;
@@ -452,31 +474,6 @@ find_segment_info (gfc_symbol *symbol)
 } 
 
 
-/* Given a variable symbol, calculate the total length in bytes of the
-   variable.  */
-
-static HOST_WIDE_INT
-calculate_length (gfc_symbol *symbol)
-{        
-  HOST_WIDE_INT j, element_size;        
-  mpz_t elements;  
-
-  if (symbol->ts.type == BT_CHARACTER)
-    gfc_conv_const_charlen (symbol->ts.cl);
-  element_size = int_size_in_bytes (gfc_typenode_for_spec (&symbol->ts));
-  if (symbol->as == NULL) 
-    return element_size;        
-
-  /* Calculate the number of elements in the array */  
-  if (spec_size (symbol->as, &elements) == FAILURE)    
-    gfc_internal_error ("calculate_length(): Unable to determine array 
size");
-  j = mpz_get_ui (elements);          
-  mpz_clear (elements);
-
-  return j*element_size;;
-}     
-
-
 /* Given an expression node, make sure it is a constant integer and return
    the mpz_t value.  */     
 
@@ -601,11 +598,8 @@ new_condition (segment_info *v, gfc_equi
   offset1 = calculate_offset (eq1->expr);
   offset2 = calculate_offset (eq2->expr);
 
-  a = get_segment_info ();
- 
-  a->sym = eq2->expr->symtree->n.sym;
-  a->offset = v->offset + offset1 - offset2;
-  a->length = calculate_length (eq2->expr->symtree->n.sym);
+  a = get_segment_info (eq2->expr->symtree->n.sym,
+			v->offset + offset1 - offset2);
  
   current_segment = add_segments (current_segment, a);
 }
@@ -728,14 +722,11 @@ add_equivalences (void)
 static void
 new_segment (gfc_common_head *common, const char *name, gfc_symbol *sym)
 {
-  HOST_WIDE_INT length;
+  current_segment = get_segment_info (sym, current_offset);
+
+  /* The offset of the next common variable.  */ 
+  current_offset += current_segment->length;
 
-  current_segment = get_segment_info ();
-  current_segment->sym = sym;
-  current_segment->offset = current_offset;
-  length = calculate_length (sym);
-  current_segment->length = length;
- 
   /* Add all object directly or indirectly equivalenced with this common
      variable.  */ 
   add_equivalences ();
@@ -745,8 +736,6 @@ new_segment (gfc_common_head *common, co
 	       "to COMMON '%s' at %L",
 	       sym->name, name, &common->where);
 
-  /* The offset of the next common variable.  */ 
-  current_offset += length;
 
   /* Add these to the common block.  */
   current_common = add_segments (current_common, current_segment);
@@ -768,10 +757,7 @@ finish_equivalences (gfc_namespace *ns)
       {
         if (y->used) continue;
         sym = z->expr->symtree->n.sym;
-        current_segment = get_segment_info ();
-        current_segment->sym = sym;
-        current_segment->offset = 0;
-        current_segment->length = calculate_length (sym);
+        current_segment = get_segment_info (sym, 0);
 
         /* All objects directly or indrectly equivalenced with this symbol.  
*/
         add_equivalences ();
Index: trans-types.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/trans-types.c,v
retrieving revision 1.5
diff -u -p -r1.5 trans-types.c
--- trans-types.c	29 Jun 2004 22:01:35 -0000	1.5
+++ trans-types.c	10 Jul 2004 02:24:15 -0000
@@ -916,7 +916,9 @@ gfc_build_pointer_type (gfc_symbol * sym
 /* Return the type for a symbol.  Special handling is required for character
    types to get the correct level of indirection.
    For functions return the return type.
-   For subroutines return void_type_node.  */
+   For subroutines return void_type_node.
+   Calling this multiple times for the same symbol should be avoided,
+   especially for character and array types.  */
 
 tree
 gfc_sym_type (gfc_symbol * sym)