/* Simulate storage of variables into target memory.
- Copyright (C) 2007
+ Copyright (C) 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Paul Thomas and Brooks Moses
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#include "tree.h"
#include "gfortran.h"
#include "arith.h"
+#include "constructor.h"
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"
size_array (gfc_expr *e)
{
mpz_t array_size;
- size_t elt_size = gfc_target_expr_size (e->value.constructor->expr);
+ gfc_constructor *c = gfc_constructor_first (e->value.constructor);
+ size_t elt_size = gfc_target_expr_size (c->expr);
gfc_array_size (e, &array_size);
return (size_t)mpz_get_ui (array_size) * elt_size;
static size_t
-size_character (int length)
+size_character (int length, int kind)
{
- return length;
+ int i = gfc_validate_kind (BT_CHARACTER, kind, false);
+ return length * gfc_character_kinds[i].bit_size / 8;
}
case BT_LOGICAL:
return size_logical (e->ts.kind);
case BT_CHARACTER:
- return size_character (e->value.character.length);
+ if (e->expr_type == EXPR_SUBSTRING && e->ref)
+ {
+ int start, end;
+
+ gfc_extract_int (e->ref->u.ss.start, &start);
+ gfc_extract_int (e->ref->u.ss.end, &end);
+ return size_character (MAX(end - start + 1, 0), e->ts.kind);
+ }
+ else
+ return size_character (e->value.character.length, e->ts.kind);
+ case BT_HOLLERITH:
+ return e->representation.length;
case BT_DERIVED:
type = gfc_typenode_for_spec (&e->ts);
return int_size_in_bytes (type);
int i;
int ptr = 0;
+ gfc_constructor_base ctor = expr->value.constructor;
+
gfc_array_size (expr, &array_size);
for (i = 0; i < (int)mpz_get_ui (array_size); i++)
{
- ptr += gfc_target_encode_expr (gfc_get_array_element (expr, i),
+ ptr += gfc_target_encode_expr (gfc_constructor_lookup_expr (ctor, i),
&buffer[ptr], buffer_size - ptr);
}
static int
encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
{
- return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind), buffer,
+ return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind, 0), buffer,
buffer_size);
}
static int
-encode_complex (int kind, mpfr_t real, mpfr_t imaginary, unsigned char *buffer,
- size_t buffer_size)
+encode_complex (int kind, mpc_t cmplx,
+ unsigned char *buffer, size_t buffer_size)
{
int size;
- size = encode_float (kind, real, &buffer[0], buffer_size);
- size += encode_float (kind, imaginary, &buffer[size], buffer_size - size);
+ size = encode_float (kind, mpc_realref (cmplx), &buffer[0], buffer_size);
+ size += encode_float (kind, mpc_imagref (cmplx),
+ &buffer[size], buffer_size - size);
return size;
}
}
-static int
-encode_character (int length, char *string, unsigned char *buffer,
- size_t buffer_size)
+int
+gfc_encode_character (int kind, int length, const gfc_char_t *string,
+ unsigned char *buffer, size_t buffer_size)
{
- gcc_assert (buffer_size >= size_character (length));
- memcpy (buffer, string, length);
+ size_t elsize = size_character (1, kind);
+ tree type = gfc_get_char_type (kind);
+ int i;
+
+ gcc_assert (buffer_size >= size_character (length, kind));
+
+ for (i = 0; i < length; i++)
+ native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],
+ elsize);
+
return length;
}
static int
encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
{
- gfc_constructor *ctr;
+ gfc_constructor *c;
gfc_component *cmp;
int ptr;
tree type;
type = gfc_typenode_for_spec (&source->ts);
- ctr = source->value.constructor;
- cmp = source->ts.derived->components;
- for (;ctr; ctr = ctr->next, cmp = cmp->next)
+ for (c = gfc_constructor_first (source->value.constructor),
+ cmp = source->ts.u.derived->components;
+ c;
+ c = gfc_constructor_next (c), cmp = cmp->next)
{
- gcc_assert (ctr->expr && cmp);
- ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
- gfc_target_encode_expr (ctr->expr, &buffer[ptr],
- buffer_size - ptr);
+ gcc_assert (cmp);
+ if (!c->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;
+
+ if (c->expr->expr_type == EXPR_NULL)
+ memset (&buffer[ptr], 0,
+ int_size_in_bytes (TREE_TYPE (cmp->backend_decl)));
+ else
+ gfc_target_encode_expr (c->expr, &buffer[ptr],
+ buffer_size - ptr);
}
return int_size_in_bytes (type);
return encode_array (source, buffer, buffer_size);
gcc_assert (source->expr_type == EXPR_CONSTANT
- || source->expr_type == EXPR_STRUCTURE);
+ || source->expr_type == EXPR_STRUCTURE
+ || source->expr_type == EXPR_SUBSTRING);
/* If we already have a target-memory representation, we use that rather
than recreating one. */
return encode_float (source->ts.kind, source->value.real, buffer,
buffer_size);
case BT_COMPLEX:
- return encode_complex (source->ts.kind, source->value.complex.r,
- source->value.complex.i, buffer, buffer_size);
+ return encode_complex (source->ts.kind, source->value.complex,
+ buffer, buffer_size);
case BT_LOGICAL:
return encode_logical (source->ts.kind, source->value.logical, buffer,
buffer_size);
case BT_CHARACTER:
- return encode_character (source->value.character.length,
- source->value.character.string, buffer,
- buffer_size);
+ if (source->expr_type == EXPR_CONSTANT || source->ref == NULL)
+ return gfc_encode_character (source->ts.kind,
+ source->value.character.length,
+ source->value.character.string,
+ buffer, buffer_size);
+ else
+ {
+ int start, end;
+
+ gcc_assert (source->expr_type == EXPR_SUBSTRING);
+ gfc_extract_int (source->ref->u.ss.start, &start);
+ gfc_extract_int (source->ref->u.ss.end, &end);
+ return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0),
+ &source->value.character.string[start-1],
+ buffer, buffer_size);
+ }
+
case BT_DERIVED:
return encode_derived (source, buffer, buffer_size);
default:
static int
interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
{
+ gfc_constructor_base base = NULL;
int array_size = 1;
int i;
int ptr = 0;
- gfc_constructor *head = NULL, *tail = NULL;
/* Calculate array size from its shape and rank. */
gcc_assert (result->rank > 0 && result->shape);
/* Iterate over array elements, producing constructors. */
for (i = 0; i < array_size; i++)
{
- if (head == NULL)
- head = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
+ gfc_expr *e = gfc_get_constant_expr (result->ts.type, result->ts.kind,
+ &result->where);
+ e->ts = result->ts;
- tail->where = result->where;
- tail->expr = gfc_constant_result (result->ts.type,
- result->ts.kind, &result->where);
- tail->expr->ts = result->ts;
+ if (e->ts.type == BT_CHARACTER)
+ e->value.character.length = result->value.character.length;
- if (tail->expr->ts.type == BT_CHARACTER)
- tail->expr->value.character.length = result->value.character.length;
+ gfc_constructor_append_expr (&base, e, &result->where);
- ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
- tail->expr);
+ ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e);
}
- result->value.constructor = head;
+ result->value.constructor = base;
return ptr;
}
int
gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
- mpfr_t real)
+ mpfr_t real)
{
+ gfc_set_model_kind (kind);
mpfr_init (real);
gfc_conv_tree_to_mpfr (real,
native_interpret_expr (gfc_get_real_type (kind),
int
gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
- mpfr_t real, mpfr_t imaginary)
+ mpc_t complex)
{
int size;
- size = gfc_interpret_float (kind, &buffer[0], buffer_size, real);
- size += gfc_interpret_float (kind, &buffer[size], buffer_size - size, imaginary);
+ size = gfc_interpret_float (kind, &buffer[0], buffer_size,
+ mpc_realref (complex));
+ size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,
+ mpc_imagref (complex));
return size;
}
int
-gfc_interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
+gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
+ gfc_expr *result)
{
- if (result->ts.cl && result->ts.cl->length)
+ int i;
+
+ if (result->ts.u.cl && result->ts.u.cl->length)
result->value.character.length =
- (int)mpz_get_ui (result->ts.cl->length->value.integer);
+ (int) mpz_get_ui (result->ts.u.cl->length->value.integer);
- gcc_assert (buffer_size >= size_character (result->value.character.length));
+ gcc_assert (buffer_size >= size_character (result->value.character.length,
+ result->ts.kind));
result->value.character.string =
- gfc_getmem (result->value.character.length + 1);
- memcpy (result->value.character.string, buffer,
- result->value.character.length);
- result->value.character.string [result->value.character.length] = '\0';
+ gfc_get_wide_string (result->value.character.length + 1);
+
+ if (result->ts.kind == gfc_default_character_kind)
+ for (i = 0; i < result->value.character.length; i++)
+ result->value.character.string[i] = (gfc_char_t) buffer[i];
+ else
+ {
+ mpz_t integer;
+ unsigned bytes = size_character (1, result->ts.kind);
+ mpz_init (integer);
+ gcc_assert (bytes <= sizeof (unsigned long));
+
+ for (i = 0; i < result->value.character.length; i++)
+ {
+ gfc_conv_tree_to_mpz (integer,
+ native_interpret_expr (gfc_get_char_type (result->ts.kind),
+ &buffer[bytes*i], buffer_size-bytes*i));
+ result->value.character.string[i]
+ = (gfc_char_t) mpz_get_ui (integer);
+ }
+
+ mpz_clear (integer);
+ }
+
+ result->value.character.string[result->value.character.length] = '\0';
return result->value.character.length;
}
gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
{
gfc_component *cmp;
- gfc_constructor *head = NULL, *tail = NULL;
int ptr;
tree type;
result->expr_type = EXPR_STRUCTURE;
type = gfc_typenode_for_spec (&result->ts);
- cmp = result->ts.derived->components;
+ cmp = result->ts.u.derived->components;
/* Run through the derived type components. */
for (;cmp; cmp = cmp->next)
{
- if (head == NULL)
- head = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
-
- /* The constructor points to the component. */
- tail->n.component = cmp;
-
- tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind,
- &result->where);
- tail->expr->ts = cmp->ts;
+ gfc_constructor *c;
+ gfc_expr *e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind,
+ &result->where);
+ e->ts = cmp->ts;
/* Copy shape, if needed. */
if (cmp->as && cmp->as->rank)
{
int n;
- tail->expr->expr_type = EXPR_ARRAY;
- tail->expr->rank = cmp->as->rank;
+ e->expr_type = EXPR_ARRAY;
+ e->rank = cmp->as->rank;
- tail->expr->shape = gfc_get_shape (tail->expr->rank);
- for (n = 0; n < tail->expr->rank; n++)
+ e->shape = gfc_get_shape (e->rank);
+ for (n = 0; n < e->rank; n++)
{
- mpz_init_set_ui (tail->expr->shape[n], 1);
- mpz_add (tail->expr->shape[n], tail->expr->shape[n],
+ mpz_init_set_ui (e->shape[n], 1);
+ mpz_add (e->shape[n], e->shape[n],
cmp->as->upper[n]->value.integer);
- mpz_sub (tail->expr->shape[n], tail->expr->shape[n],
+ mpz_sub (e->shape[n], e->shape[n],
cmp->as->lower[n]->value.integer);
}
}
- ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
- gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
- tail->expr);
+ c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
+
+ /* The constructor points to the component. */
+ c->n.component = cmp;
- result->value.constructor = head;
+ ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
+ gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e);
}
return int_size_in_bytes (type);
case BT_COMPLEX:
result->representation.length =
gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
- result->value.complex.r,
- result->value.complex.i);
+ result->value.complex);
break;
case BT_LOGICAL:
}
if (result->ts.type == BT_CHARACTER)
- result->representation.string = result->value.character.string;
+ result->representation.string
+ = gfc_widechar_to_char (result->value.character.string,
+ result->value.character.length);
else
{
result->representation.string =
- gfc_getmem (result->representation.length + 1);
+ (char *) gfc_getmem (result->representation.length + 1);
memcpy (result->representation.string, buffer,
result->representation.length);
result->representation.string[result->representation.length] = '\0';
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 *c;
+ 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)
+ {
+ for (c = gfc_constructor_first (e->value.constructor),
+ cmp = e->ts.u.derived->components;
+ c; c = gfc_constructor_next (c), cmp = cmp->next)
+ {
+ gcc_assert (cmp && cmp->backend_decl);
+ if (!c->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 (c->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 = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
+ {
+ size_t elt_size = gfc_target_expr_size (c->expr);
+
+ if (c->offset)
+ len = elt_size * (size_t)mpz_get_si (c->offset);
+
+ len = len + gfc_merge_initializers (ts, c->expr, &data[len],
+ &chk[len], length - len);
+ }
+ break;
+
+ default:
+ return 0;
+ }
+
+ return len;
+}
+
+
+/* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
+ When successful, no BOZ or nothing to do, true is returned. */
+
+bool
+gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
+{
+ size_t buffer_size, boz_bit_size, ts_bit_size;
+ int index;
+ unsigned char *buffer;
+
+ if (!expr->is_boz)
+ return true;
+
+ gcc_assert (expr->expr_type == EXPR_CONSTANT
+ && expr->ts.type == BT_INTEGER);
+
+ /* Don't convert BOZ to logical, character, derived etc. */
+ if (ts->type == BT_REAL)
+ {
+ buffer_size = size_float (ts->kind);
+ ts_bit_size = buffer_size * 8;
+ }
+ else if (ts->type == BT_COMPLEX)
+ {
+ buffer_size = size_complex (ts->kind);
+ ts_bit_size = buffer_size * 8 / 2;
+ }
+ else
+ return true;
+
+ /* Convert BOZ to the smallest possible integer kind. */
+ boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
+
+ if (boz_bit_size > ts_bit_size)
+ {
+ gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",
+ &expr->where, (long) boz_bit_size, (long) ts_bit_size);
+ return false;
+ }
+
+ for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
+ if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
+ break;
+
+ expr->ts.kind = gfc_integer_kinds[index].kind;
+ buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
+
+ buffer = (unsigned char*)alloca (buffer_size);
+ encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
+ mpz_clear (expr->value.integer);
+
+ if (ts->type == BT_REAL)
+ {
+ mpfr_init (expr->value.real);
+ gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
+ }
+ else
+ {
+ mpc_init2 (expr->value.complex, mpfr_get_default_prec());
+ gfc_interpret_complex (ts->kind, buffer, buffer_size,
+ expr->value.complex);
+ }
+ expr->is_boz = 0;
+ expr->ts.type = ts->type;
+ expr->ts.kind = ts->kind;
+
+ return true;
+}
OSDN Git Service
