re PR fortran/13415 (Internal error with pointer array in common)

	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.

Co-Authored-By: Paul Brook <paul@codesourcery.com>

From-SVN: r84439

gcc/fortran/ChangeLog

+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.
+
 2004-07-09  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
 	
 	PR fortran/14077

gcc/fortran/trans-common.c

@@ -106,11 +106,13 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA
 #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, *current_common;
 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  *name)
 }
 
 
-/* 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_type, record_layout_info rli)
                             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, const char *name)
 
   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_equiv *eq1, gfc_equiv *eq2)
   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, const char *name, gfc_symbol *sym)
 	       "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 ();

gcc/fortran/trans-types.c

@@ -916,7 +916,9 @@ gfc_build_pointer_type (gfc_symbol * sym, tree type)
 /* 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)

gcc/testsuite/ChangeLog

+2004-07-10 Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+	Paul Brook  <paul@codesourcery.com>
+
+	PR fortran/13415
+	* gfortran.dg/common_pointer_1.f90: New test.
+
 2004-07-10  Giovanni Bajo  <giovannibajo@gcc.gnu.org>
 
 	* g++.dg/lookup/new1.C: Fix dg-excess-error syntax.

gcc/testsuite/gfortran.dg/common_pointer_1.f90

+! { dg-do run }
+! PR13415
+! Test pointer variables in common blocks.
+
+subroutine test
+  implicit none
+  real, pointer :: p(:), q
+  common /block/ p, q
+
+  if (any (p .ne. (/1.0, 2.0/)) .or. (q .ne. 42.0)) call abort ()
+end subroutine
+
+program common_pointer_1
+  implicit none
+  real, target :: a(2), b
+  real, pointer :: x(:), y
+  common /block/ x, y
+  
+  a = (/1.0, 2.0/)
+  b = 42.0
+  x=>a
+  y=>b
+  call test
+end program