From: Paul Thomas Date: Mon, 11 Jun 2007 22:39:21 +0000 (+0000) Subject: re PR fortran/29786 (Initialization of overlapping variables: Not implemented) X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=9d99ee7be4ce581cac42b20b08982ecefed84c2b;p=platform%2Fupstream%2Fgcc.git re PR fortran/29786 (Initialization of overlapping variables: Not implemented) 2007-06-12 Paul Thomas PR fortran/29786 PR fortran/30875 * trans-common.c (get_init_field): New function. (create_common): Call get_init_field for overlapping initializers in equivalence blocks. * resolve.c (resolve_equivalence_derived, resolve_equivalence): Remove constraints on initializers in equivalence blocks. * target-memory.c (expr_to_char, gfc_merge_initializers): New functions. (encode_derived): Add the bit offset to the byte offset to get the total offset to the field. * target-memory.h : Add prototype for gfc_merge_initializers. 2007-06-12 Paul Thomas PR fortran/29786 * gfortran.dg/equiv_7.f90: New test. * gfortran.dg/equiv_constraint_7.f90: Change error message. PR fortran/30875 * gfortran.dg/equiv_constraint_5.f90: Correct code and error. From-SVN: r125628 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 32fb023..bb56dec 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2007-06-12 Paul Thomas + + PR fortran/29786 + PR fortran/30875 + * trans-common.c (get_init_field): New function. + (create_common): Call get_init_field for overlapping + initializers in equivalence blocks. + * resolve.c (resolve_equivalence_derived, resolve_equivalence): + Remove constraints on initializers in equivalence blocks. + * target-memory.c (expr_to_char, gfc_merge_initializers): + New functions. + (encode_derived): Add the bit offset to the byte offset to get + the total offset to the field. + * target-memory.h : Add prototype for gfc_merge_initializers. + 2007-06-11 Rafael Avila de Espindola * trans-types.c (gfc_signed_type): Remove. diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 74aa915..99797aa 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -6992,14 +6992,6 @@ resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) sym->name, &e->where); return FAILURE; } - - if (c->initializer) - { - gfc_error ("Derived type variable '%s' at %L with default " - "initializer cannot be an EQUIVALENCE object", - sym->name, &e->where); - return FAILURE; - } } return SUCCESS; } @@ -7122,21 +7114,6 @@ resolve_equivalence (gfc_equiv *eq) break; } - /* An equivalence statement cannot have more than one initialized - object. */ - if (sym->value) - { - if (value_name != NULL) - { - gfc_error ("Initialized objects '%s' and '%s' cannot both " - "be in the EQUIVALENCE statement at %L", - value_name, sym->name, &e->where); - continue; - } - else - value_name = sym->name; - } - /* Shall not equivalence common block variables in a PURE procedure. */ if (sym->ns->proc_name && sym->ns->proc_name->attr.pure diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c index e235744..561a8f1 100644 --- a/gcc/fortran/target-memory.c +++ b/gcc/fortran/target-memory.c @@ -198,8 +198,11 @@ encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size) cmp = source->ts.derived->components; for (;ctr; ctr = ctr->next, cmp = cmp->next) { - gcc_assert (ctr->expr && cmp); - ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl)); + gcc_assert (cmp); + if (!ctr->expr) + continue; + ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl)) + + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8; gfc_target_encode_expr (ctr->expr, &buffer[ptr], buffer_size - ptr); } @@ -491,3 +494,105 @@ gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size, return result->representation.length; } + + +/* --------------------------------------------------------------- */ +/* Two functions used by trans-common.c to write overlapping + equivalence initializers to a buffer. This is added to the union + and the original initializers freed. */ + + +/* Writes the values of a constant expression to a char buffer. If another + unequal initializer has already been written to the buffer, this is an + error. */ + +static size_t +expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len) +{ + int i; + int ptr; + gfc_constructor *ctr; + gfc_component *cmp; + unsigned char *buffer; + + if (e == NULL) + return 0; + + /* Take a derived type, one component at a time, using the offsets from the backend + declaration. */ + if (e->ts.type == BT_DERIVED) + { + ctr = e->value.constructor; + cmp = e->ts.derived->components; + for (;ctr; ctr = ctr->next, cmp = cmp->next) + { + gcc_assert (cmp && cmp->backend_decl); + if (!ctr->expr) + continue; + ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl)) + + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8; + expr_to_char (ctr->expr, &data[ptr], &chk[ptr], len); + } + return len; + } + + /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate + to the target, in a buffer and check off the initialized part of the buffer. */ + len = gfc_target_expr_size (e); + buffer = (unsigned char*)alloca (len); + len = gfc_target_encode_expr (e, buffer, len); + + for (i = 0; i < (int)len; i++) + { + if (chk[i] && (buffer[i] != data[i])) + { + gfc_error ("Overlapping unequal initializers in EQUIVALENCE " + "at %L", &e->where); + return 0; + } + chk[i] = 0xFF; + } + + memcpy (data, buffer, len); + return len; +} + + +/* Writes the values from the equivalence initializers to a char* array + that will be written to the constructor to make the initializer for + the union declaration. */ + +size_t +gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data, + unsigned char *chk, size_t length) +{ + size_t len = 0; + gfc_constructor * c; + + switch (e->expr_type) + { + case EXPR_CONSTANT: + case EXPR_STRUCTURE: + len = expr_to_char (e, &data[0], &chk[0], length); + + break; + + case EXPR_ARRAY: + for (c = e->value.constructor; c; c = c->next) + { + size_t elt_size = gfc_target_expr_size (c->expr); + + if (c->n.offset) + len = elt_size * (size_t)mpz_get_si (c->n.offset); + + len = len + gfc_merge_initializers (ts, c->expr, &data[len], + &chk[len], length - len); + } + break; + + default: + return 0; + } + + return len; +} diff --git a/gcc/fortran/target-memory.h b/gcc/fortran/target-memory.h index 8e35e69..b8f6d04 100644 --- a/gcc/fortran/target-memory.h +++ b/gcc/fortran/target-memory.h @@ -41,4 +41,9 @@ int gfc_interpret_character (unsigned char *, size_t, gfc_expr *); int gfc_interpret_derived (unsigned char *, size_t, gfc_expr *); int gfc_target_interpret_expr (unsigned char *, size_t, gfc_expr *); +/* Merge overlapping equivalence initializers for trans-common.c. */ +size_t gfc_merge_initializers (gfc_typespec, gfc_expr *, + unsigned char *, unsigned char *, + size_t); + #endif /* GFC_TARGET_MEMORY_H */ diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index bde7ea5..e39ec59 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -106,6 +106,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA #include "trans.h" #include "trans-types.h" #include "trans-const.h" +#include "target-memory.h" /* Holds a single variable in an equivalence set. */ @@ -413,6 +414,110 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) } +/* Return a field that is the size of the union, if an equivalence has + overlapping initializers. Merge the initializers into a single + initializer for this new field, then free the old ones. */ + +static tree +get_init_field (segment_info *head, tree union_type, tree *field_init, + record_layout_info rli) +{ + segment_info *s; + HOST_WIDE_INT length = 0; + HOST_WIDE_INT offset = 0; + unsigned HOST_WIDE_INT known_align, desired_align; + bool overlap = false; + tree tmp, field; + tree init; + unsigned char *data, *chk; + VEC(constructor_elt,gc) *v = NULL; + + tree type = unsigned_char_type_node; + int i; + + /* Obtain the size of the union and check if there are any overlapping + initializers. */ + for (s = head; s; s = s->next) + { + HOST_WIDE_INT slen = s->offset + s->length; + if (s->sym->value) + { + if (s->offset < offset) + overlap = true; + offset = slen; + } + length = length < slen ? slen : length; + } + + if (!overlap) + return NULL_TREE; + + /* Now absorb all the initializer data into a single vector, + whilst checking for overlapping, unequal values. */ + data = (unsigned char*)gfc_getmem ((size_t)length); + chk = (unsigned char*)gfc_getmem ((size_t)length); + + /* TODO - change this when default initialization is implemented. */ + memset (data, '\0', (size_t)length); + memset (chk, '\0', (size_t)length); + for (s = head; s; s = s->next) + if (s->sym->value) + gfc_merge_initializers (s->sym->ts, s->sym->value, + &data[s->offset], + &chk[s->offset], + (size_t)s->length); + + for (i = 0; i < length; i++) + CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i])); + + gfc_free (data); + gfc_free (chk); + + /* Build a char[length] array to hold the initializers. Much of what + follows is borrowed from build_field, above. */ + + tmp = build_int_cst (gfc_array_index_type, length - 1); + tmp = build_range_type (gfc_array_index_type, + gfc_index_zero_node, tmp); + tmp = build_array_type (type, tmp); + field = build_decl (FIELD_DECL, NULL_TREE, tmp); + gfc_set_decl_location (field, &gfc_current_locus); + + known_align = BIGGEST_ALIGNMENT; + + desired_align = update_alignment_for_field (rli, field, known_align); + if (desired_align > known_align) + DECL_PACKED (field) = 1; + + DECL_FIELD_CONTEXT (field) = union_type; + DECL_FIELD_OFFSET (field) = size_int (0); + DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node; + SET_DECL_OFFSET_ALIGN (field, known_align); + + rli->offset = size_binop (MAX_EXPR, rli->offset, + size_binop (PLUS_EXPR, + DECL_FIELD_OFFSET (field), + DECL_SIZE_UNIT (field))); + + init = build_constructor (TREE_TYPE (field), v); + TREE_CONSTANT (init) = 1; + TREE_INVARIANT (init) = 1; + + *field_init = init; + + for (s = head; s; s = s->next) + { + if (s->sym->value == NULL) + continue; + + gfc_free_expr (s->sym->value); + s->sym->value = NULL; + } + + return field; +} + + /* Declare memory for the common block or local equivalence, and create backend declarations for all of the elements. */ @@ -422,6 +527,8 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) segment_info *s, *next_s; tree union_type; tree *field_link; + tree field; + tree field_init; record_layout_info rli; tree decl; bool is_init = false; @@ -440,6 +547,20 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) rli = start_record_layout (union_type); field_link = &TYPE_FIELDS (union_type); + /* Check for overlapping initializers and replace them with a single, + artificial field that contains all the data. */ + if (saw_equiv) + field = get_init_field (head, union_type, &field_init, rli); + else + field = NULL_TREE; + + if (field != NULL_TREE) + { + is_init = true; + *field_link = field; + field_link = &TREE_CHAIN (field); + } + for (s = head; s; s = s->next) { build_field (s, union_type, rli); @@ -456,6 +577,7 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) if (s->sym->attr.save) is_saved = true; } + finish_record_layout (rli, true); if (com) @@ -469,29 +591,23 @@ create_common (gfc_common_head *com, segment_info *head, bool saw_equiv) HOST_WIDE_INT offset = 0; VEC(constructor_elt,gc) *v = NULL; - for (s = head; s; s = s->next) - { - if (s->sym->value) - { - if (s->offset < offset) - { - /* We have overlapping initializers. It could either be - partially initialized arrays (legal), or the user - specified multiple initial values (illegal). - We don't implement this yet, so bail out. */ - gfc_todo_error ("Initialization of overlapping variables"); - } - /* Add the initializer for this field. */ - tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts, - TREE_TYPE (s->field), - s->sym->attr.dimension, - s->sym->attr.pointer - || s->sym->attr.allocatable); - - CONSTRUCTOR_APPEND_ELT (v, s->field, tmp); - offset = s->offset + s->length; - } - } + if (field != NULL_TREE && field_init != NULL_TREE) + CONSTRUCTOR_APPEND_ELT (v, field, field_init); + else + for (s = head; s; s = s->next) + { + if (s->sym->value) + { + /* Add the initializer for this field. */ + tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts, + TREE_TYPE (s->field), s->sym->attr.dimension, + s->sym->attr.pointer || s->sym->attr.allocatable); + + CONSTRUCTOR_APPEND_ELT (v, s->field, tmp); + offset = s->offset + s->length; + } + } + gcc_assert (!VEC_empty (constructor_elt, v)); ctor = build_constructor (union_type, v); TREE_CONSTANT (ctor) = 1; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2392241..1e40136 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2007-06-12 Paul Thomas + + PR fortran/29786 + * gfortran.dg/equiv_7.f90: New test. + * gfortran.dg/equiv_constraint_7.f90: Change error message. + + PR fortran/30875 + * gfortran.dg/equiv_constraint_5.f90: Correct code and error. + 2007-06-11 Andreas Tobler * gcc.dg/setjmp-3.c: Rename raise to raise0. diff --git a/gcc/testsuite/gfortran.dg/equiv_7.f90 b/gcc/testsuite/gfortran.dg/equiv_7.f90 new file mode 100644 index 0000000..51beba7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/equiv_7.f90 @@ -0,0 +1,92 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! Tests the fix for PR29786, in which initialization of overlapping +! equivalence elements caused a compile error. +! +! Contributed by Bernhard Fischer +! +block data + common /global/ ca (4) + integer(4) ca, cb + equivalence (cb, ca(3)) + data (ca(i), i = 1, 2) /42,43/, ca(4) /44/ + data cb /99/ +end block data + + call int4_int4 + call real4_real4 + call complex_real + call check_block_data + call derived_types ! Thanks to Tobias Burnus for this:) +! +! This came up in PR29786 comment #9 +! + if (d1mach (1) .ne. transfer ((/0_4, 1048576_4/), 1d0)) call abort () + if (d1mach (2) .ne. transfer ((/-1_4,2146435071_4/), 1d0)) call abort () +! +contains + subroutine int4_int4 + integer(4) a(4) + integer(4) b + equivalence (b,a(3)) + data b/3/ + data (a(i), i=1,2) /1,2/, a(4) /4/ + if (any (a .ne. (/1, 2, 3, 4/))) call abort () + end subroutine int4_int4 + subroutine real4_real4 + real(4) a(4) + real(4) b + equivalence (b,a(3)) + data b/3.0_4/ + data (a(i), i=1,2) /1.0_4, 2.0_4/, & + a(4) /4.0_4/ + if (sum (abs (a - & + (/1.0_4, 2.0_4, 3.0_4, 4.0_4/))) > 1.0e-6) call abort () + end subroutine real4_real4 + subroutine complex_real + complex(4) a(4) + real(4) b(2) + equivalence (b,a(3)) + data b(1)/3.0_4/, b(2)/4.0_4/ + data (a(i), i=1,2) /(0.0_4, 1.0_4),(2.0_4,0.0_4)/, & + a(4) /(0.0_4,5.0_4)/ + if (sum (abs (a - (/(0.0_4, 1.0_4),(2.0_4, 0.0_4), & + (3.0_4, 4.0_4),(0.0_4, 5.0_4)/))) > 1.0e-6) call abort () + end subroutine complex_real + subroutine check_block_data + common /global/ ca (4) + equivalence (ca(3), cb) + integer(4) ca + if (any (ca .ne. (/42, 43, 99, 44/))) call abort () + end subroutine check_block_data + function d1mach(i) + implicit none + double precision d1mach,dmach(5) + integer i,large(4),small(4) + equivalence ( dmach(1), small(1) ) + equivalence ( dmach(2), large(1) ) + data small(1),small(2) / 0, 1048576/ + data large(1),large(2) /-1,2146435071/ + d1mach = dmach(i) + end function d1mach + subroutine derived_types + TYPE T1 + sequence + character (3) :: chr + integer :: i = 1 + integer :: j + END TYPE T1 + TYPE T2 + sequence + character (3) :: chr = "wxy" + integer :: i = 1 + integer :: j = 4 + END TYPE T2 + TYPE(T1) :: a1 + TYPE(T2) :: a2 + EQUIVALENCE(a1,a2) ! { dg-warning="mixed|components" } + if (a1%chr .ne. "wxy") call abort () + if (a1%i .ne. 1) call abort () + if (a1%j .ne. 4) call abort () + end subroutine derived_types +end diff --git a/gcc/testsuite/gfortran.dg/equiv_constraint_5.f90 b/gcc/testsuite/gfortran.dg/equiv_constraint_5.f90 index 1eefa81..1f7dddc 100644 --- a/gcc/testsuite/gfortran.dg/equiv_constraint_5.f90 +++ b/gcc/testsuite/gfortran.dg/equiv_constraint_5.f90 @@ -1,18 +1,31 @@ ! { dg-do compile } ! { dg-options "-O0" } -! PR20902 - Structure with default initializer cannot be equivalence memeber. +! PR20902 - Overlapping initializers in an equivalence block must +! have the same value. +! +! The code was replaced completely after the fix for PR30875, which +! is a repeat of the original and comes from the same contributor. +! The fix for 20902 was wrong. +! ! Contributed by Joost VandeVondele -TYPE T1 - sequence - integer :: i=1 -END TYPE T1 -TYPE T2 - sequence - integer :: i ! drop original initializer to pick up error below. -END TYPE T2 -TYPE(T1) :: a1 -TYPE(T2) :: a2 -EQUIVALENCE(a1,a2) ! { dg-error "initializer cannot be an EQUIVALENCE" } -write(6,*) a1,a2 +! + TYPE T1 + sequence + integer :: i=1 + END TYPE T1 + TYPE T2 ! OK because initializers are equal + sequence + integer :: i=1 + END TYPE T2 + TYPE T3 + sequence + integer :: i=2 ! { dg-error "Overlapping unequal initializers" } + END TYPE T3 + TYPE(T1) :: a1 + TYPE(T2) :: a2 + TYPE(T3) :: a3 + EQUIVALENCE (a1, a2) + EQUIVALENCE (a1, a3) + write(6, *) a1, a2, a3 END diff --git a/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90 b/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90 index 207b7d3..872e05b 100644 --- a/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90 +++ b/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90 @@ -1,11 +1,11 @@ ! { dg-do compile } ! { dg-options "-O0" } -! PR20890 - Equivalence cannot contain more than one initialized variables. +! PR20890 - Equivalence cannot contain overlapping unequal initializers. ! Contributed by Joost VandeVondele ! Started out being in BLOCK DATA; however, blockdata variables must be in ! COMMON and therefore cannot have F95 style initializers.... MODULE DATA - INTEGER :: I=1,J=2 - EQUIVALENCE(I,J) ! { dg-error "cannot both be in the EQUIVALENCE" } + INTEGER :: I=1,J=2 ! { dg-error "Overlapping unequal initializers" } + EQUIVALENCE(I,J) END MODULE DATA END