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
This commit is contained in:
parent
3ee7acd137
commit
ad6e2a18c2
|
@ -1,3 +1,14 @@
|
|||
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
|
||||
|
|
|
@ -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 ();
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -1,3 +1,9 @@
|
|||
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.
|
||||
|
|
|
@ -0,0 +1,24 @@
|
|||
! { 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
|
Loading…
Reference in New Issue