From ad6e2a18c2013863e1cf448471e1fa243403eb50 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Tobias=20Schl=C3=BCter?= Date: Sat, 10 Jul 2004 02:46:54 +0000 Subject: [PATCH] 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 From-SVN: r84439 --- gcc/fortran/ChangeLog | 11 +++ gcc/fortran/trans-common.c | 98 ++++++++----------- gcc/fortran/trans-types.c | 4 +- gcc/testsuite/ChangeLog | 6 ++ .../gfortran.dg/common_pointer_1.f90 | 24 +++++ 5 files changed, 86 insertions(+), 57 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/common_pointer_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c3f70930f08..7cfab030d7a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2004-07-10 Tobias Schlueter + Paul Brook + + 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 PR fortran/14077 diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index 152f7d43850..800ab93cb11 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -106,11 +106,13 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA #include +/* 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 (); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 46146a941a0..74e3972f1aa 100644 --- a/gcc/fortran/trans-types.c +++ b/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) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 46bbed5abde..84c1a9e90c1 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2004-07-10 Tobias Schlueter + Paul Brook + + PR fortran/13415 + * gfortran.dg/common_pointer_1.f90: New test. + 2004-07-10 Giovanni Bajo * g++.dg/lookup/new1.C: Fix dg-excess-error syntax. diff --git a/gcc/testsuite/gfortran.dg/common_pointer_1.f90 b/gcc/testsuite/gfortran.dg/common_pointer_1.f90 new file mode 100644 index 00000000000..e0f90ca72be --- /dev/null +++ b/gcc/testsuite/gfortran.dg/common_pointer_1.f90 @@ -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 -- 2.30.2