+2007-06-12 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <espindola@google.com>
* trans-types.c (gfc_signed_type): Remove.
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;
}
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
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);
}
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;
+}
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 */
#include "trans.h"
#include "trans-types.h"
#include "trans-const.h"
+#include "target-memory.h"
/* Holds a single variable in an equivalence set. */
}
+/* 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. */
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;
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);
if (s->sym->attr.save)
is_saved = true;
}
+
finish_record_layout (rli, true);
if (com)
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;
+2007-06-12 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <a.tobler@schweiz.org>
* gcc.dg/setjmp-3.c: Rename raise to raise0.
--- /dev/null
+! { 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 <aldot@gcc.gnu.org>
+!
+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
! { 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 <jv244@cam.ac.uk>
-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
! { 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 <jv244@cam.ac.uk>
! 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
OSDN Git Service
