/* Simulate storage of variables into target memory.
|
/* Simulate storage of variables into target memory.
|
Copyright (C) 2007, 2008, 2009
|
Copyright (C) 2007, 2008, 2009
|
Free Software Foundation, Inc.
|
Free Software Foundation, Inc.
|
Contributed by Paul Thomas and Brooks Moses
|
Contributed by Paul Thomas and Brooks Moses
|
|
|
This file is part of GCC.
|
This file is part of GCC.
|
|
|
GCC is free software; you can redistribute it and/or modify it under
|
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
|
the terms of the GNU General Public License as published by the Free
|
Software Foundation; either version 3, or (at your option) any later
|
Software Foundation; either version 3, or (at your option) any later
|
version.
|
version.
|
|
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
for more details.
|
for more details.
|
|
|
You should have received a copy of the GNU General Public License
|
You should have received a copy of the GNU General Public License
|
along with GCC; see the file COPYING3. If not see
|
along with GCC; see the file COPYING3. If not see
|
<http://www.gnu.org/licenses/>. */
|
<http://www.gnu.org/licenses/>. */
|
|
|
#include "config.h"
|
#include "config.h"
|
#include "system.h"
|
#include "system.h"
|
#include "flags.h"
|
#include "flags.h"
|
#include "machmode.h"
|
#include "machmode.h"
|
#include "tree.h"
|
#include "tree.h"
|
#include "gfortran.h"
|
#include "gfortran.h"
|
#include "arith.h"
|
#include "arith.h"
|
#include "trans.h"
|
#include "trans.h"
|
#include "trans-const.h"
|
#include "trans-const.h"
|
#include "trans-types.h"
|
#include "trans-types.h"
|
#include "target-memory.h"
|
#include "target-memory.h"
|
|
|
/* --------------------------------------------------------------- */
|
/* --------------------------------------------------------------- */
|
/* Calculate the size of an expression. */
|
/* Calculate the size of an expression. */
|
|
|
static size_t
|
static size_t
|
size_array (gfc_expr *e)
|
size_array (gfc_expr *e)
|
{
|
{
|
mpz_t array_size;
|
mpz_t array_size;
|
size_t elt_size = gfc_target_expr_size (e->value.constructor->expr);
|
size_t elt_size = gfc_target_expr_size (e->value.constructor->expr);
|
|
|
gfc_array_size (e, &array_size);
|
gfc_array_size (e, &array_size);
|
return (size_t)mpz_get_ui (array_size) * elt_size;
|
return (size_t)mpz_get_ui (array_size) * elt_size;
|
}
|
}
|
|
|
static size_t
|
static size_t
|
size_integer (int kind)
|
size_integer (int kind)
|
{
|
{
|
return GET_MODE_SIZE (TYPE_MODE (gfc_get_int_type (kind)));;
|
return GET_MODE_SIZE (TYPE_MODE (gfc_get_int_type (kind)));;
|
}
|
}
|
|
|
|
|
static size_t
|
static size_t
|
size_float (int kind)
|
size_float (int kind)
|
{
|
{
|
return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind)));;
|
return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind)));;
|
}
|
}
|
|
|
|
|
static size_t
|
static size_t
|
size_complex (int kind)
|
size_complex (int kind)
|
{
|
{
|
return 2 * size_float (kind);
|
return 2 * size_float (kind);
|
}
|
}
|
|
|
|
|
static size_t
|
static size_t
|
size_logical (int kind)
|
size_logical (int kind)
|
{
|
{
|
return GET_MODE_SIZE (TYPE_MODE (gfc_get_logical_type (kind)));;
|
return GET_MODE_SIZE (TYPE_MODE (gfc_get_logical_type (kind)));;
|
}
|
}
|
|
|
|
|
static size_t
|
static size_t
|
size_character (int length, int kind)
|
size_character (int length, int kind)
|
{
|
{
|
int i = gfc_validate_kind (BT_CHARACTER, kind, false);
|
int i = gfc_validate_kind (BT_CHARACTER, kind, false);
|
return length * gfc_character_kinds[i].bit_size / 8;
|
return length * gfc_character_kinds[i].bit_size / 8;
|
}
|
}
|
|
|
|
|
size_t
|
size_t
|
gfc_target_expr_size (gfc_expr *e)
|
gfc_target_expr_size (gfc_expr *e)
|
{
|
{
|
tree type;
|
tree type;
|
|
|
gcc_assert (e != NULL);
|
gcc_assert (e != NULL);
|
|
|
if (e->expr_type == EXPR_ARRAY)
|
if (e->expr_type == EXPR_ARRAY)
|
return size_array (e);
|
return size_array (e);
|
|
|
switch (e->ts.type)
|
switch (e->ts.type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
return size_integer (e->ts.kind);
|
return size_integer (e->ts.kind);
|
case BT_REAL:
|
case BT_REAL:
|
return size_float (e->ts.kind);
|
return size_float (e->ts.kind);
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
return size_complex (e->ts.kind);
|
return size_complex (e->ts.kind);
|
case BT_LOGICAL:
|
case BT_LOGICAL:
|
return size_logical (e->ts.kind);
|
return size_logical (e->ts.kind);
|
case BT_CHARACTER:
|
case BT_CHARACTER:
|
if (e->expr_type == EXPR_SUBSTRING && e->ref)
|
if (e->expr_type == EXPR_SUBSTRING && e->ref)
|
{
|
{
|
int start, end;
|
int start, end;
|
|
|
gfc_extract_int (e->ref->u.ss.start, &start);
|
gfc_extract_int (e->ref->u.ss.start, &start);
|
gfc_extract_int (e->ref->u.ss.end, &end);
|
gfc_extract_int (e->ref->u.ss.end, &end);
|
return size_character (MAX(end - start + 1, 0), e->ts.kind);
|
return size_character (MAX(end - start + 1, 0), e->ts.kind);
|
}
|
}
|
else
|
else
|
return size_character (e->value.character.length, e->ts.kind);
|
return size_character (e->value.character.length, e->ts.kind);
|
case BT_HOLLERITH:
|
case BT_HOLLERITH:
|
return e->representation.length;
|
return e->representation.length;
|
case BT_DERIVED:
|
case BT_DERIVED:
|
type = gfc_typenode_for_spec (&e->ts);
|
type = gfc_typenode_for_spec (&e->ts);
|
return int_size_in_bytes (type);
|
return int_size_in_bytes (type);
|
default:
|
default:
|
gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
|
gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
|
return 0;
|
return 0;
|
}
|
}
|
}
|
}
|
|
|
|
|
/* The encode_* functions export a value into a buffer, and
|
/* The encode_* functions export a value into a buffer, and
|
return the number of bytes of the buffer that have been
|
return the number of bytes of the buffer that have been
|
used. */
|
used. */
|
|
|
static int
|
static int
|
encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size)
|
encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size)
|
{
|
{
|
mpz_t array_size;
|
mpz_t array_size;
|
int i;
|
int i;
|
int ptr = 0;
|
int ptr = 0;
|
|
|
gfc_array_size (expr, &array_size);
|
gfc_array_size (expr, &array_size);
|
for (i = 0; i < (int)mpz_get_ui (array_size); i++)
|
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_get_array_element (expr, i),
|
&buffer[ptr], buffer_size - ptr);
|
&buffer[ptr], buffer_size - ptr);
|
}
|
}
|
|
|
mpz_clear (array_size);
|
mpz_clear (array_size);
|
return ptr;
|
return ptr;
|
}
|
}
|
|
|
|
|
static int
|
static int
|
encode_integer (int kind, mpz_t integer, unsigned char *buffer,
|
encode_integer (int kind, mpz_t integer, unsigned char *buffer,
|
size_t buffer_size)
|
size_t buffer_size)
|
{
|
{
|
return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
|
return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
|
buffer, buffer_size);
|
buffer, buffer_size);
|
}
|
}
|
|
|
|
|
static int
|
static int
|
encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
|
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, 0), buffer,
|
return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind, 0), buffer,
|
buffer_size);
|
buffer_size);
|
}
|
}
|
|
|
|
|
static int
|
static int
|
encode_complex (int kind, mpc_t cmplx,
|
encode_complex (int kind, mpc_t cmplx,
|
unsigned char *buffer, size_t buffer_size)
|
unsigned char *buffer, size_t buffer_size)
|
{
|
{
|
int size;
|
int size;
|
size = encode_float (kind, mpc_realref (cmplx), &buffer[0], buffer_size);
|
size = encode_float (kind, mpc_realref (cmplx), &buffer[0], buffer_size);
|
size += encode_float (kind, mpc_imagref (cmplx),
|
size += encode_float (kind, mpc_imagref (cmplx),
|
&buffer[size], buffer_size - size);
|
&buffer[size], buffer_size - size);
|
return size;
|
return size;
|
}
|
}
|
|
|
|
|
static int
|
static int
|
encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
|
encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
|
{
|
{
|
return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
|
return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
|
logical),
|
logical),
|
buffer, buffer_size);
|
buffer, buffer_size);
|
}
|
}
|
|
|
|
|
int
|
int
|
gfc_encode_character (int kind, int length, const gfc_char_t *string,
|
gfc_encode_character (int kind, int length, const gfc_char_t *string,
|
unsigned char *buffer, size_t buffer_size)
|
unsigned char *buffer, size_t buffer_size)
|
{
|
{
|
size_t elsize = size_character (1, kind);
|
size_t elsize = size_character (1, kind);
|
tree type = gfc_get_char_type (kind);
|
tree type = gfc_get_char_type (kind);
|
int i;
|
int i;
|
|
|
gcc_assert (buffer_size >= size_character (length, kind));
|
gcc_assert (buffer_size >= size_character (length, kind));
|
|
|
for (i = 0; i < length; i++)
|
for (i = 0; i < length; i++)
|
native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],
|
native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],
|
elsize);
|
elsize);
|
|
|
return length;
|
return length;
|
}
|
}
|
|
|
|
|
static int
|
static int
|
encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
|
encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
|
{
|
{
|
gfc_constructor *ctr;
|
gfc_constructor *ctr;
|
gfc_component *cmp;
|
gfc_component *cmp;
|
int ptr;
|
int ptr;
|
tree type;
|
tree type;
|
|
|
type = gfc_typenode_for_spec (&source->ts);
|
type = gfc_typenode_for_spec (&source->ts);
|
|
|
ctr = source->value.constructor;
|
ctr = source->value.constructor;
|
cmp = source->ts.u.derived->components;
|
cmp = source->ts.u.derived->components;
|
for (;ctr; ctr = ctr->next, cmp = cmp->next)
|
for (;ctr; ctr = ctr->next, cmp = cmp->next)
|
{
|
{
|
gcc_assert (cmp);
|
gcc_assert (cmp);
|
if (!ctr->expr)
|
if (!ctr->expr)
|
continue;
|
continue;
|
ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
|
ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
|
+ TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
|
+ TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
|
|
|
if (ctr->expr->expr_type == EXPR_NULL)
|
if (ctr->expr->expr_type == EXPR_NULL)
|
memset (&buffer[ptr], 0,
|
memset (&buffer[ptr], 0,
|
int_size_in_bytes (TREE_TYPE (cmp->backend_decl)));
|
int_size_in_bytes (TREE_TYPE (cmp->backend_decl)));
|
else
|
else
|
gfc_target_encode_expr (ctr->expr, &buffer[ptr],
|
gfc_target_encode_expr (ctr->expr, &buffer[ptr],
|
buffer_size - ptr);
|
buffer_size - ptr);
|
}
|
}
|
|
|
return int_size_in_bytes (type);
|
return int_size_in_bytes (type);
|
}
|
}
|
|
|
|
|
/* Write a constant expression in binary form to a buffer. */
|
/* Write a constant expression in binary form to a buffer. */
|
int
|
int
|
gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
|
gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
|
size_t buffer_size)
|
size_t buffer_size)
|
{
|
{
|
if (source == NULL)
|
if (source == NULL)
|
return 0;
|
return 0;
|
|
|
if (source->expr_type == EXPR_ARRAY)
|
if (source->expr_type == EXPR_ARRAY)
|
return encode_array (source, buffer, buffer_size);
|
return encode_array (source, buffer, buffer_size);
|
|
|
gcc_assert (source->expr_type == EXPR_CONSTANT
|
gcc_assert (source->expr_type == EXPR_CONSTANT
|
|| source->expr_type == EXPR_STRUCTURE
|
|| source->expr_type == EXPR_STRUCTURE
|
|| source->expr_type == EXPR_SUBSTRING);
|
|| source->expr_type == EXPR_SUBSTRING);
|
|
|
/* If we already have a target-memory representation, we use that rather
|
/* If we already have a target-memory representation, we use that rather
|
than recreating one. */
|
than recreating one. */
|
if (source->representation.string)
|
if (source->representation.string)
|
{
|
{
|
memcpy (buffer, source->representation.string,
|
memcpy (buffer, source->representation.string,
|
source->representation.length);
|
source->representation.length);
|
return source->representation.length;
|
return source->representation.length;
|
}
|
}
|
|
|
switch (source->ts.type)
|
switch (source->ts.type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
return encode_integer (source->ts.kind, source->value.integer, buffer,
|
return encode_integer (source->ts.kind, source->value.integer, buffer,
|
buffer_size);
|
buffer_size);
|
case BT_REAL:
|
case BT_REAL:
|
return encode_float (source->ts.kind, source->value.real, buffer,
|
return encode_float (source->ts.kind, source->value.real, buffer,
|
buffer_size);
|
buffer_size);
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
return encode_complex (source->ts.kind, source->value.complex,
|
return encode_complex (source->ts.kind, source->value.complex,
|
buffer, buffer_size);
|
buffer, buffer_size);
|
case BT_LOGICAL:
|
case BT_LOGICAL:
|
return encode_logical (source->ts.kind, source->value.logical, buffer,
|
return encode_logical (source->ts.kind, source->value.logical, buffer,
|
buffer_size);
|
buffer_size);
|
case BT_CHARACTER:
|
case BT_CHARACTER:
|
if (source->expr_type == EXPR_CONSTANT || source->ref == NULL)
|
if (source->expr_type == EXPR_CONSTANT || source->ref == NULL)
|
return gfc_encode_character (source->ts.kind,
|
return gfc_encode_character (source->ts.kind,
|
source->value.character.length,
|
source->value.character.length,
|
source->value.character.string,
|
source->value.character.string,
|
buffer, buffer_size);
|
buffer, buffer_size);
|
else
|
else
|
{
|
{
|
int start, end;
|
int start, end;
|
|
|
gcc_assert (source->expr_type == EXPR_SUBSTRING);
|
gcc_assert (source->expr_type == EXPR_SUBSTRING);
|
gfc_extract_int (source->ref->u.ss.start, &start);
|
gfc_extract_int (source->ref->u.ss.start, &start);
|
gfc_extract_int (source->ref->u.ss.end, &end);
|
gfc_extract_int (source->ref->u.ss.end, &end);
|
return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0),
|
return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0),
|
&source->value.character.string[start-1],
|
&source->value.character.string[start-1],
|
buffer, buffer_size);
|
buffer, buffer_size);
|
}
|
}
|
|
|
case BT_DERIVED:
|
case BT_DERIVED:
|
return encode_derived (source, buffer, buffer_size);
|
return encode_derived (source, buffer, buffer_size);
|
default:
|
default:
|
gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
|
gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
|
return 0;
|
return 0;
|
}
|
}
|
}
|
}
|
|
|
|
|
static int
|
static int
|
interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
|
interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
|
{
|
{
|
int array_size = 1;
|
int array_size = 1;
|
int i;
|
int i;
|
int ptr = 0;
|
int ptr = 0;
|
gfc_constructor *head = NULL, *tail = NULL;
|
gfc_constructor *head = NULL, *tail = NULL;
|
|
|
/* Calculate array size from its shape and rank. */
|
/* Calculate array size from its shape and rank. */
|
gcc_assert (result->rank > 0 && result->shape);
|
gcc_assert (result->rank > 0 && result->shape);
|
|
|
for (i = 0; i < result->rank; i++)
|
for (i = 0; i < result->rank; i++)
|
array_size *= (int)mpz_get_ui (result->shape[i]);
|
array_size *= (int)mpz_get_ui (result->shape[i]);
|
|
|
/* Iterate over array elements, producing constructors. */
|
/* Iterate over array elements, producing constructors. */
|
for (i = 0; i < array_size; i++)
|
for (i = 0; i < array_size; i++)
|
{
|
{
|
if (head == NULL)
|
if (head == NULL)
|
head = tail = gfc_get_constructor ();
|
head = tail = gfc_get_constructor ();
|
else
|
else
|
{
|
{
|
tail->next = gfc_get_constructor ();
|
tail->next = gfc_get_constructor ();
|
tail = tail->next;
|
tail = tail->next;
|
}
|
}
|
|
|
tail->where = result->where;
|
tail->where = result->where;
|
tail->expr = gfc_constant_result (result->ts.type,
|
tail->expr = gfc_constant_result (result->ts.type,
|
result->ts.kind, &result->where);
|
result->ts.kind, &result->where);
|
tail->expr->ts = result->ts;
|
tail->expr->ts = result->ts;
|
|
|
if (tail->expr->ts.type == BT_CHARACTER)
|
if (tail->expr->ts.type == BT_CHARACTER)
|
tail->expr->value.character.length = result->value.character.length;
|
tail->expr->value.character.length = result->value.character.length;
|
|
|
ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
|
ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
|
tail->expr);
|
tail->expr);
|
}
|
}
|
result->value.constructor = head;
|
result->value.constructor = head;
|
|
|
return ptr;
|
return ptr;
|
}
|
}
|
|
|
|
|
int
|
int
|
gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
|
gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
|
mpz_t integer)
|
mpz_t integer)
|
{
|
{
|
mpz_init (integer);
|
mpz_init (integer);
|
gfc_conv_tree_to_mpz (integer,
|
gfc_conv_tree_to_mpz (integer,
|
native_interpret_expr (gfc_get_int_type (kind),
|
native_interpret_expr (gfc_get_int_type (kind),
|
buffer, buffer_size));
|
buffer, buffer_size));
|
return size_integer (kind);
|
return size_integer (kind);
|
}
|
}
|
|
|
|
|
int
|
int
|
gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
|
gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
|
mpfr_t real)
|
mpfr_t real)
|
{
|
{
|
gfc_set_model_kind (kind);
|
gfc_set_model_kind (kind);
|
mpfr_init (real);
|
mpfr_init (real);
|
gfc_conv_tree_to_mpfr (real,
|
gfc_conv_tree_to_mpfr (real,
|
native_interpret_expr (gfc_get_real_type (kind),
|
native_interpret_expr (gfc_get_real_type (kind),
|
buffer, buffer_size));
|
buffer, buffer_size));
|
|
|
return size_float (kind);
|
return size_float (kind);
|
}
|
}
|
|
|
|
|
int
|
int
|
gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
|
gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
|
mpc_t complex)
|
mpc_t complex)
|
{
|
{
|
int size;
|
int size;
|
size = gfc_interpret_float (kind, &buffer[0], buffer_size,
|
size = gfc_interpret_float (kind, &buffer[0], buffer_size,
|
mpc_realref (complex));
|
mpc_realref (complex));
|
size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,
|
size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,
|
mpc_imagref (complex));
|
mpc_imagref (complex));
|
return size;
|
return size;
|
}
|
}
|
|
|
|
|
int
|
int
|
gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
|
gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
|
int *logical)
|
int *logical)
|
{
|
{
|
tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
|
tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
|
buffer_size);
|
buffer_size);
|
*logical = double_int_zero_p (tree_to_double_int (t))
|
*logical = double_int_zero_p (tree_to_double_int (t))
|
? 0 : 1;
|
? 0 : 1;
|
return size_logical (kind);
|
return size_logical (kind);
|
}
|
}
|
|
|
|
|
int
|
int
|
gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
|
gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
|
gfc_expr *result)
|
gfc_expr *result)
|
{
|
{
|
int i;
|
int i;
|
|
|
if (result->ts.u.cl && result->ts.u.cl->length)
|
if (result->ts.u.cl && result->ts.u.cl->length)
|
result->value.character.length =
|
result->value.character.length =
|
(int) mpz_get_ui (result->ts.u.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->ts.kind));
|
result->value.character.string =
|
result->value.character.string =
|
gfc_get_wide_string (result->value.character.length + 1);
|
gfc_get_wide_string (result->value.character.length + 1);
|
|
|
if (result->ts.kind == gfc_default_character_kind)
|
if (result->ts.kind == gfc_default_character_kind)
|
for (i = 0; i < result->value.character.length; i++)
|
for (i = 0; i < result->value.character.length; i++)
|
result->value.character.string[i] = (gfc_char_t) buffer[i];
|
result->value.character.string[i] = (gfc_char_t) buffer[i];
|
else
|
else
|
{
|
{
|
mpz_t integer;
|
mpz_t integer;
|
unsigned bytes = size_character (1, result->ts.kind);
|
unsigned bytes = size_character (1, result->ts.kind);
|
mpz_init (integer);
|
mpz_init (integer);
|
gcc_assert (bytes <= sizeof (unsigned long));
|
gcc_assert (bytes <= sizeof (unsigned long));
|
|
|
for (i = 0; i < result->value.character.length; i++)
|
for (i = 0; i < result->value.character.length; i++)
|
{
|
{
|
gfc_conv_tree_to_mpz (integer,
|
gfc_conv_tree_to_mpz (integer,
|
native_interpret_expr (gfc_get_char_type (result->ts.kind),
|
native_interpret_expr (gfc_get_char_type (result->ts.kind),
|
&buffer[bytes*i], buffer_size-bytes*i));
|
&buffer[bytes*i], buffer_size-bytes*i));
|
result->value.character.string[i]
|
result->value.character.string[i]
|
= (gfc_char_t) mpz_get_ui (integer);
|
= (gfc_char_t) mpz_get_ui (integer);
|
}
|
}
|
|
|
mpz_clear (integer);
|
mpz_clear (integer);
|
}
|
}
|
|
|
result->value.character.string[result->value.character.length] = '\0';
|
result->value.character.string[result->value.character.length] = '\0';
|
|
|
return result->value.character.length;
|
return result->value.character.length;
|
}
|
}
|
|
|
|
|
int
|
int
|
gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
|
gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
|
{
|
{
|
gfc_component *cmp;
|
gfc_component *cmp;
|
gfc_constructor *head = NULL, *tail = NULL;
|
gfc_constructor *head = NULL, *tail = NULL;
|
int ptr;
|
int ptr;
|
tree type;
|
tree type;
|
|
|
/* The attributes of the derived type need to be bolted to the floor. */
|
/* The attributes of the derived type need to be bolted to the floor. */
|
result->expr_type = EXPR_STRUCTURE;
|
result->expr_type = EXPR_STRUCTURE;
|
|
|
type = gfc_typenode_for_spec (&result->ts);
|
type = gfc_typenode_for_spec (&result->ts);
|
cmp = result->ts.u.derived->components;
|
cmp = result->ts.u.derived->components;
|
|
|
/* Run through the derived type components. */
|
/* Run through the derived type components. */
|
for (;cmp; cmp = cmp->next)
|
for (;cmp; cmp = cmp->next)
|
{
|
{
|
if (head == NULL)
|
if (head == NULL)
|
head = tail = gfc_get_constructor ();
|
head = tail = gfc_get_constructor ();
|
else
|
else
|
{
|
{
|
tail->next = gfc_get_constructor ();
|
tail->next = gfc_get_constructor ();
|
tail = tail->next;
|
tail = tail->next;
|
}
|
}
|
|
|
/* The constructor points to the component. */
|
/* The constructor points to the component. */
|
tail->n.component = cmp;
|
tail->n.component = cmp;
|
|
|
tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind,
|
tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind,
|
&result->where);
|
&result->where);
|
tail->expr->ts = cmp->ts;
|
tail->expr->ts = cmp->ts;
|
|
|
/* Copy shape, if needed. */
|
/* Copy shape, if needed. */
|
if (cmp->as && cmp->as->rank)
|
if (cmp->as && cmp->as->rank)
|
{
|
{
|
int n;
|
int n;
|
|
|
tail->expr->expr_type = EXPR_ARRAY;
|
tail->expr->expr_type = EXPR_ARRAY;
|
tail->expr->rank = cmp->as->rank;
|
tail->expr->rank = cmp->as->rank;
|
|
|
tail->expr->shape = gfc_get_shape (tail->expr->rank);
|
tail->expr->shape = gfc_get_shape (tail->expr->rank);
|
for (n = 0; n < tail->expr->rank; n++)
|
for (n = 0; n < tail->expr->rank; n++)
|
{
|
{
|
mpz_init_set_ui (tail->expr->shape[n], 1);
|
mpz_init_set_ui (tail->expr->shape[n], 1);
|
mpz_add (tail->expr->shape[n], tail->expr->shape[n],
|
mpz_add (tail->expr->shape[n], tail->expr->shape[n],
|
cmp->as->upper[n]->value.integer);
|
cmp->as->upper[n]->value.integer);
|
mpz_sub (tail->expr->shape[n], tail->expr->shape[n],
|
mpz_sub (tail->expr->shape[n], tail->expr->shape[n],
|
cmp->as->lower[n]->value.integer);
|
cmp->as->lower[n]->value.integer);
|
}
|
}
|
}
|
}
|
|
|
ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
|
ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
|
gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
|
gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
|
tail->expr);
|
tail->expr);
|
|
|
result->value.constructor = head;
|
result->value.constructor = head;
|
}
|
}
|
|
|
return int_size_in_bytes (type);
|
return int_size_in_bytes (type);
|
}
|
}
|
|
|
|
|
/* Read a binary buffer to a constant expression. */
|
/* Read a binary buffer to a constant expression. */
|
int
|
int
|
gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
|
gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
|
gfc_expr *result)
|
gfc_expr *result)
|
{
|
{
|
if (result->expr_type == EXPR_ARRAY)
|
if (result->expr_type == EXPR_ARRAY)
|
return interpret_array (buffer, buffer_size, result);
|
return interpret_array (buffer, buffer_size, result);
|
|
|
switch (result->ts.type)
|
switch (result->ts.type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
result->representation.length =
|
result->representation.length =
|
gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
|
gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
|
result->value.integer);
|
result->value.integer);
|
break;
|
break;
|
|
|
case BT_REAL:
|
case BT_REAL:
|
result->representation.length =
|
result->representation.length =
|
gfc_interpret_float (result->ts.kind, buffer, buffer_size,
|
gfc_interpret_float (result->ts.kind, buffer, buffer_size,
|
result->value.real);
|
result->value.real);
|
break;
|
break;
|
|
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
result->representation.length =
|
result->representation.length =
|
gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
|
gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
|
result->value.complex);
|
result->value.complex);
|
break;
|
break;
|
|
|
case BT_LOGICAL:
|
case BT_LOGICAL:
|
result->representation.length =
|
result->representation.length =
|
gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
|
gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
|
&result->value.logical);
|
&result->value.logical);
|
break;
|
break;
|
|
|
case BT_CHARACTER:
|
case BT_CHARACTER:
|
result->representation.length =
|
result->representation.length =
|
gfc_interpret_character (buffer, buffer_size, result);
|
gfc_interpret_character (buffer, buffer_size, result);
|
break;
|
break;
|
|
|
case BT_DERIVED:
|
case BT_DERIVED:
|
result->representation.length =
|
result->representation.length =
|
gfc_interpret_derived (buffer, buffer_size, result);
|
gfc_interpret_derived (buffer, buffer_size, result);
|
break;
|
break;
|
|
|
default:
|
default:
|
gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
|
gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
|
break;
|
break;
|
}
|
}
|
|
|
if (result->ts.type == BT_CHARACTER)
|
if (result->ts.type == BT_CHARACTER)
|
result->representation.string
|
result->representation.string
|
= gfc_widechar_to_char (result->value.character.string,
|
= gfc_widechar_to_char (result->value.character.string,
|
result->value.character.length);
|
result->value.character.length);
|
else
|
else
|
{
|
{
|
result->representation.string =
|
result->representation.string =
|
(char *) gfc_getmem (result->representation.length + 1);
|
(char *) gfc_getmem (result->representation.length + 1);
|
memcpy (result->representation.string, buffer,
|
memcpy (result->representation.string, buffer,
|
result->representation.length);
|
result->representation.length);
|
result->representation.string[result->representation.length] = '\0';
|
result->representation.string[result->representation.length] = '\0';
|
}
|
}
|
|
|
return result->representation.length;
|
return result->representation.length;
|
}
|
}
|
|
|
|
|
/* --------------------------------------------------------------- */
|
/* --------------------------------------------------------------- */
|
/* Two functions used by trans-common.c to write overlapping
|
/* Two functions used by trans-common.c to write overlapping
|
equivalence initializers to a buffer. This is added to the union
|
equivalence initializers to a buffer. This is added to the union
|
and the original initializers freed. */
|
and the original initializers freed. */
|
|
|
|
|
/* Writes the values of a constant expression to a char buffer. If another
|
/* 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
|
unequal initializer has already been written to the buffer, this is an
|
error. */
|
error. */
|
|
|
static size_t
|
static size_t
|
expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len)
|
expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len)
|
{
|
{
|
int i;
|
int i;
|
int ptr;
|
int ptr;
|
gfc_constructor *ctr;
|
gfc_constructor *ctr;
|
gfc_component *cmp;
|
gfc_component *cmp;
|
unsigned char *buffer;
|
unsigned char *buffer;
|
|
|
if (e == NULL)
|
if (e == NULL)
|
return 0;
|
return 0;
|
|
|
/* Take a derived type, one component at a time, using the offsets from the backend
|
/* Take a derived type, one component at a time, using the offsets from the backend
|
declaration. */
|
declaration. */
|
if (e->ts.type == BT_DERIVED)
|
if (e->ts.type == BT_DERIVED)
|
{
|
{
|
ctr = e->value.constructor;
|
ctr = e->value.constructor;
|
cmp = e->ts.u.derived->components;
|
cmp = e->ts.u.derived->components;
|
for (;ctr; ctr = ctr->next, cmp = cmp->next)
|
for (;ctr; ctr = ctr->next, cmp = cmp->next)
|
{
|
{
|
gcc_assert (cmp && cmp->backend_decl);
|
gcc_assert (cmp && cmp->backend_decl);
|
if (!ctr->expr)
|
if (!ctr->expr)
|
continue;
|
continue;
|
ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
|
ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
|
+ TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
|
+ TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
|
expr_to_char (ctr->expr, &data[ptr], &chk[ptr], len);
|
expr_to_char (ctr->expr, &data[ptr], &chk[ptr], len);
|
}
|
}
|
return len;
|
return len;
|
}
|
}
|
|
|
/* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
|
/* 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. */
|
to the target, in a buffer and check off the initialized part of the buffer. */
|
len = gfc_target_expr_size (e);
|
len = gfc_target_expr_size (e);
|
buffer = (unsigned char*)alloca (len);
|
buffer = (unsigned char*)alloca (len);
|
len = gfc_target_encode_expr (e, buffer, len);
|
len = gfc_target_encode_expr (e, buffer, len);
|
|
|
for (i = 0; i < (int)len; i++)
|
for (i = 0; i < (int)len; i++)
|
{
|
{
|
if (chk[i] && (buffer[i] != data[i]))
|
if (chk[i] && (buffer[i] != data[i]))
|
{
|
{
|
gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
|
gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
|
"at %L", &e->where);
|
"at %L", &e->where);
|
return 0;
|
return 0;
|
}
|
}
|
chk[i] = 0xFF;
|
chk[i] = 0xFF;
|
}
|
}
|
|
|
memcpy (data, buffer, len);
|
memcpy (data, buffer, len);
|
return len;
|
return len;
|
}
|
}
|
|
|
|
|
/* Writes the values from the equivalence initializers to a char* array
|
/* Writes the values from the equivalence initializers to a char* array
|
that will be written to the constructor to make the initializer for
|
that will be written to the constructor to make the initializer for
|
the union declaration. */
|
the union declaration. */
|
|
|
size_t
|
size_t
|
gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data,
|
gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data,
|
unsigned char *chk, size_t length)
|
unsigned char *chk, size_t length)
|
{
|
{
|
size_t len = 0;
|
size_t len = 0;
|
gfc_constructor * c;
|
gfc_constructor * c;
|
|
|
switch (e->expr_type)
|
switch (e->expr_type)
|
{
|
{
|
case EXPR_CONSTANT:
|
case EXPR_CONSTANT:
|
case EXPR_STRUCTURE:
|
case EXPR_STRUCTURE:
|
len = expr_to_char (e, &data[0], &chk[0], length);
|
len = expr_to_char (e, &data[0], &chk[0], length);
|
|
|
break;
|
break;
|
|
|
case EXPR_ARRAY:
|
case EXPR_ARRAY:
|
for (c = e->value.constructor; c; c = c->next)
|
for (c = e->value.constructor; c; c = c->next)
|
{
|
{
|
size_t elt_size = gfc_target_expr_size (c->expr);
|
size_t elt_size = gfc_target_expr_size (c->expr);
|
|
|
if (c->n.offset)
|
if (c->n.offset)
|
len = elt_size * (size_t)mpz_get_si (c->n.offset);
|
len = elt_size * (size_t)mpz_get_si (c->n.offset);
|
|
|
len = len + gfc_merge_initializers (ts, c->expr, &data[len],
|
len = len + gfc_merge_initializers (ts, c->expr, &data[len],
|
&chk[len], length - len);
|
&chk[len], length - len);
|
}
|
}
|
break;
|
break;
|
|
|
default:
|
default:
|
return 0;
|
return 0;
|
}
|
}
|
|
|
return len;
|
return len;
|
}
|
}
|
|
|
|
|
/* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
|
/* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
|
When successful, no BOZ or nothing to do, true is returned. */
|
When successful, no BOZ or nothing to do, true is returned. */
|
|
|
bool
|
bool
|
gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
|
gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
|
{
|
{
|
size_t buffer_size, boz_bit_size, ts_bit_size;
|
size_t buffer_size, boz_bit_size, ts_bit_size;
|
int index;
|
int index;
|
unsigned char *buffer;
|
unsigned char *buffer;
|
|
|
if (!expr->is_boz)
|
if (!expr->is_boz)
|
return true;
|
return true;
|
|
|
gcc_assert (expr->expr_type == EXPR_CONSTANT
|
gcc_assert (expr->expr_type == EXPR_CONSTANT
|
&& expr->ts.type == BT_INTEGER);
|
&& expr->ts.type == BT_INTEGER);
|
|
|
/* Don't convert BOZ to logical, character, derived etc. */
|
/* Don't convert BOZ to logical, character, derived etc. */
|
if (ts->type == BT_REAL)
|
if (ts->type == BT_REAL)
|
{
|
{
|
buffer_size = size_float (ts->kind);
|
buffer_size = size_float (ts->kind);
|
ts_bit_size = buffer_size * 8;
|
ts_bit_size = buffer_size * 8;
|
}
|
}
|
else if (ts->type == BT_COMPLEX)
|
else if (ts->type == BT_COMPLEX)
|
{
|
{
|
buffer_size = size_complex (ts->kind);
|
buffer_size = size_complex (ts->kind);
|
ts_bit_size = buffer_size * 8 / 2;
|
ts_bit_size = buffer_size * 8 / 2;
|
}
|
}
|
else
|
else
|
return true;
|
return true;
|
|
|
/* Convert BOZ to the smallest possible integer kind. */
|
/* Convert BOZ to the smallest possible integer kind. */
|
boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
|
boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
|
|
|
if (boz_bit_size > ts_bit_size)
|
if (boz_bit_size > ts_bit_size)
|
{
|
{
|
gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",
|
gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",
|
&expr->where, (long) boz_bit_size, (long) ts_bit_size);
|
&expr->where, (long) boz_bit_size, (long) ts_bit_size);
|
return false;
|
return false;
|
}
|
}
|
|
|
for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
|
for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
|
if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
|
if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
|
break;
|
break;
|
|
|
expr->ts.kind = gfc_integer_kinds[index].kind;
|
expr->ts.kind = gfc_integer_kinds[index].kind;
|
buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
|
buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
|
|
|
buffer = (unsigned char*)alloca (buffer_size);
|
buffer = (unsigned char*)alloca (buffer_size);
|
encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
|
encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
|
mpz_clear (expr->value.integer);
|
mpz_clear (expr->value.integer);
|
|
|
if (ts->type == BT_REAL)
|
if (ts->type == BT_REAL)
|
{
|
{
|
mpfr_init (expr->value.real);
|
mpfr_init (expr->value.real);
|
gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
|
gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
|
}
|
}
|
else
|
else
|
{
|
{
|
mpc_init2 (expr->value.complex, mpfr_get_default_prec());
|
mpc_init2 (expr->value.complex, mpfr_get_default_prec());
|
gfc_interpret_complex (ts->kind, buffer, buffer_size,
|
gfc_interpret_complex (ts->kind, buffer, buffer_size,
|
expr->value.complex);
|
expr->value.complex);
|
}
|
}
|
expr->is_boz = 0;
|
expr->is_boz = 0;
|
expr->ts.type = ts->type;
|
expr->ts.type = ts->type;
|
expr->ts.kind = ts->kind;
|
expr->ts.kind = ts->kind;
|
|
|
return true;
|
return true;
|
}
|
}
|
|
|
