URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [fortran/] [target-memory.c] - Blame information for rev 301

Go to most recent revision | Details | Compare with Previous | View Log


/* Simulate storage of variables into target memory.
   Copyright (C) 2007, 2008, 2009
   Free Software Foundation, Inc.
   Contributed by Paul Thomas and Brooks Moses
 
This file is part of GCC.
 
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 3, or (at your option) any later
version.
 
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.
 
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3.  If not see
<http://www.gnu.org/licenses/>.  */
 
#include "config.h"
#include "system.h"
#include "flags.h"
#include "machmode.h"
#include "tree.h"
#include "gfortran.h"
#include "arith.h"
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"
#include "target-memory.h"
 
/* --------------------------------------------------------------- */
/* Calculate the size of an expression.  */
 
static size_t
size_array (gfc_expr *e)
{
  mpz_t array_size;
  size_t elt_size = gfc_target_expr_size (e->value.constructor->expr);
 
  gfc_array_size (e, &array_size);
  return (size_t)mpz_get_ui (array_size) * elt_size;
}
 
static size_t
size_integer (int kind)
{
  return GET_MODE_SIZE (TYPE_MODE (gfc_get_int_type (kind)));;
}
 
 
static size_t
size_float (int kind)
{
  return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind)));;
}
 
 
static size_t
size_complex (int kind)
{
  return 2 * size_float (kind);
}
 
 
static size_t
size_logical (int kind)
{
  return GET_MODE_SIZE (TYPE_MODE (gfc_get_logical_type (kind)));;
}
 
 
static size_t
size_character (int length, int kind)
{
  int i = gfc_validate_kind (BT_CHARACTER, kind, false);
  return length * gfc_character_kinds[i].bit_size / 8;
}
 
 
size_t
gfc_target_expr_size (gfc_expr *e)
{
  tree type;
 
  gcc_assert (e != NULL);
 
  if (e->expr_type == EXPR_ARRAY)
    return size_array (e);
 
  switch (e->ts.type)
    {
    case BT_INTEGER:
      return size_integer (e->ts.kind);
    case BT_REAL:
      return size_float (e->ts.kind);
    case BT_COMPLEX:
      return size_complex (e->ts.kind);
    case BT_LOGICAL:
      return size_logical (e->ts.kind);
    case BT_CHARACTER:
      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);
    default:
      gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
      return 0;
    }
}
 
 
/* The encode_* functions export a value into a buffer, and
   return the number of bytes of the buffer that have been
   used.  */
 
static int
encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size)
{
  mpz_t array_size;
  int i;
  int ptr = 0;
 
  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),
                                     &buffer[ptr], buffer_size - ptr);
    }
 
  mpz_clear (array_size);
  return ptr;
}
 
 
static int
encode_integer (int kind, mpz_t integer, unsigned char *buffer,
                size_t buffer_size)
{
  return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
                             buffer, buffer_size);
}
 
 
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, 0), buffer,
                             buffer_size);
}
 
 
static int
encode_complex (int kind, mpc_t cmplx,
                unsigned char *buffer, size_t buffer_size)
{
  int 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_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
{
  return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
                                            logical),
                             buffer, buffer_size);
}
 
 
int
gfc_encode_character (int kind, int length, const gfc_char_t *string,
                      unsigned char *buffer, size_t buffer_size)
{
  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_component *cmp;
  int ptr;
  tree type;
 
  type = gfc_typenode_for_spec (&source->ts);
 
  ctr = source->value.constructor;
  cmp = source->ts.u.derived->components;
  for (;ctr; ctr = ctr->next, cmp = cmp->next)
    {
      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;
 
      if (ctr->expr->expr_type == EXPR_NULL)
        memset (&buffer[ptr], 0,
                int_size_in_bytes (TREE_TYPE (cmp->backend_decl)));
      else
        gfc_target_encode_expr (ctr->expr, &buffer[ptr],
                                buffer_size - ptr);
    }
 
  return int_size_in_bytes (type);
}
 
 
/* Write a constant expression in binary form to a buffer.  */
int
gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
                        size_t buffer_size)
{
  if (source == NULL)
    return 0;
 
  if (source->expr_type == EXPR_ARRAY)
    return encode_array (source, buffer, buffer_size);
 
  gcc_assert (source->expr_type == EXPR_CONSTANT
              || 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.  */
  if (source->representation.string)
    {
      memcpy (buffer, source->representation.string,
              source->representation.length);
      return source->representation.length;
    }
 
  switch (source->ts.type)
    {
    case BT_INTEGER:
      return encode_integer (source->ts.kind, source->value.integer, buffer,
                             buffer_size);
    case BT_REAL:
      return encode_float (source->ts.kind, source->value.real, buffer,
                           buffer_size);
    case BT_COMPLEX:
      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:
      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:
      gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
      return 0;
    }
}
 
 
static int
interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
{
  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);
 
  for (i = 0; i < result->rank; i++)
    array_size *= (int)mpz_get_ui (result->shape[i]);
 
  /* 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;
        }
 
      tail->where = result->where;
      tail->expr = gfc_constant_result (result->ts.type,
                                          result->ts.kind, &result->where);
      tail->expr->ts = result->ts;
 
      if (tail->expr->ts.type == BT_CHARACTER)
        tail->expr->value.character.length = result->value.character.length;
 
      ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
                                        tail->expr);
    }
  result->value.constructor = head;
 
  return ptr;
}
 
 
int
gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
                   mpz_t integer)
{
  mpz_init (integer);
  gfc_conv_tree_to_mpz (integer,
                        native_interpret_expr (gfc_get_int_type (kind),
                                               buffer, buffer_size));
  return size_integer (kind);
}
 
 
int
gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
                     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),
                                                buffer, buffer_size));
 
  return size_float (kind);
}
 
 
int
gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
                       mpc_t complex)
{
  int size;
  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_logical (int kind, unsigned char *buffer, size_t buffer_size,
                   int *logical)
{
  tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
                                  buffer_size);
  *logical = double_int_zero_p (tree_to_double_int (t))
             ? 0 : 1;
  return size_logical (kind);
}
 
 
int
gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
                         gfc_expr *result)
{
  int i;
 
  if (result->ts.u.cl && result->ts.u.cl->length)
    result->value.character.length =
      (int) mpz_get_ui (result->ts.u.cl->length->value.integer);
 
  gcc_assert (buffer_size >= size_character (result->value.character.length,
                                             result->ts.kind));
  result->value.character.string =
    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;
}
 
 
int
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;
 
  /* The attributes of the derived type need to be bolted to the floor.  */
  result->expr_type = EXPR_STRUCTURE;
 
  type = gfc_typenode_for_spec (&result->ts);
  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;
 
      /* Copy shape, if needed.  */
      if (cmp->as && cmp->as->rank)
        {
          int n;
 
          tail->expr->expr_type = EXPR_ARRAY;
          tail->expr->rank = cmp->as->rank;
 
          tail->expr->shape = gfc_get_shape (tail->expr->rank);
          for (n = 0; n < tail->expr->rank; n++)
             {
               mpz_init_set_ui (tail->expr->shape[n], 1);
               mpz_add (tail->expr->shape[n], tail->expr->shape[n],
                        cmp->as->upper[n]->value.integer);
               mpz_sub (tail->expr->shape[n], tail->expr->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);
 
      result->value.constructor = head;
    }
 
  return int_size_in_bytes (type);
}
 
 
/* Read a binary buffer to a constant expression.  */
int
gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
                           gfc_expr *result)
{
  if (result->expr_type == EXPR_ARRAY)
    return interpret_array (buffer, buffer_size, result);
 
  switch (result->ts.type)
    {
    case BT_INTEGER:
      result->representation.length =
        gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
                               result->value.integer);
      break;
 
    case BT_REAL:
      result->representation.length =
        gfc_interpret_float (result->ts.kind, buffer, buffer_size,
                             result->value.real);
      break;
 
    case BT_COMPLEX:
      result->representation.length =
        gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
                               result->value.complex);
      break;
 
    case BT_LOGICAL:
      result->representation.length =
        gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
                               &result->value.logical);
      break;
 
    case BT_CHARACTER:
      result->representation.length =
        gfc_interpret_character (buffer, buffer_size, result);
      break;
 
    case BT_DERIVED:
      result->representation.length =
        gfc_interpret_derived (buffer, buffer_size, result);
      break;
 
    default:
      gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
      break;
    }
 
  if (result->ts.type == BT_CHARACTER)
    result->representation.string
      = gfc_widechar_to_char (result->value.character.string,
                              result->value.character.length);
  else
    {
      result->representation.string =
        (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 *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.u.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;
}
 
 
/* 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;
}

Browse

Tools

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [fortran/] [target-memory.c] - Blame information for rev 301

Line No.	Rev	Author	Line
1	285	jeremybenn	`/* Simulate storage of variables into target memory.`
2			`Copyright (C) 2007, 2008, 2009`
3			`Free Software Foundation, Inc.`
4			`Contributed by Paul Thomas and Brooks Moses`
5
6			`This file is part of GCC.`
7
8			`GCC is free software; you can redistribute it and/or modify it under`
9			`the terms of the GNU General Public License as published by the Free`
10			`Software Foundation; either version 3, or (at your option) any later`
11			`version.`
12
13			`GCC is distributed in the hope that it will be useful, but WITHOUT ANY`
14			`WARRANTY; without even the implied warranty of MERCHANTABILITY or`
15			`FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License`
16			`for more details.`
17
18			`You should have received a copy of the GNU General Public License`
19			`along with GCC; see the file COPYING3. If not see`
20			`<http://www.gnu.org/licenses/>. */`
21
22			`#include "config.h"`
23			`#include "system.h"`
24			`#include "flags.h"`
25			`#include "machmode.h"`
26			`#include "tree.h"`
27			`#include "gfortran.h"`
28			`#include "arith.h"`
29			`#include "trans.h"`
30			`#include "trans-const.h"`
31			`#include "trans-types.h"`
32			`#include "target-memory.h"`
33
34			`/* --------------------------------------------------------------- */`
35			`/* Calculate the size of an expression. */`
36
37			`static size_t`
38			`size_array (gfc_expr *e)`
39			`{`
40			`mpz_t array_size;`
41			`size_t elt_size = gfc_target_expr_size (e->value.constructor->expr);`
42
43			`gfc_array_size (e, &array_size);`
44			`return (size_t)mpz_get_ui (array_size) * elt_size;`
45			`}`
46
47			`static size_t`
48			`size_integer (int kind)`
49			`{`
50			`return GET_MODE_SIZE (TYPE_MODE (gfc_get_int_type (kind)));;`
51			`}`
52
53
54			`static size_t`
55			`size_float (int kind)`
56			`{`
57			`return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind)));;`
58			`}`
59
60
61			`static size_t`
62			`size_complex (int kind)`
63			`{`
64			`return 2 * size_float (kind);`
65			`}`
66
67
68			`static size_t`
69			`size_logical (int kind)`
70			`{`
71			`return GET_MODE_SIZE (TYPE_MODE (gfc_get_logical_type (kind)));;`
72			`}`
73
74
75			`static size_t`
76			`size_character (int length, int kind)`
77			`{`
78			`int i = gfc_validate_kind (BT_CHARACTER, kind, false);`
79			`return length * gfc_character_kinds[i].bit_size / 8;`
80			`}`
81
82
83			`size_t`
84			`gfc_target_expr_size (gfc_expr *e)`
85			`{`
86			`tree type;`
87
88			`gcc_assert (e != NULL);`
89
90			`if (e->expr_type == EXPR_ARRAY)`
91			`return size_array (e);`
92
93			`switch (e->ts.type)`
94			`{`
95			`case BT_INTEGER:`
96			`return size_integer (e->ts.kind);`
97			`case BT_REAL:`
98			`return size_float (e->ts.kind);`
99			`case BT_COMPLEX:`
100			`return size_complex (e->ts.kind);`
101			`case BT_LOGICAL:`
102			`return size_logical (e->ts.kind);`
103			`case BT_CHARACTER:`
104			`if (e->expr_type == EXPR_SUBSTRING && e->ref)`
105			`{`
106			`int start, end;`
107
108			`gfc_extract_int (e->ref->u.ss.start, &start);`
109			`gfc_extract_int (e->ref->u.ss.end, &end);`
110			`return size_character (MAX(end - start + 1, 0), e->ts.kind);`
111			`}`
112			`else`
113			`return size_character (e->value.character.length, e->ts.kind);`
114			`case BT_HOLLERITH:`
115			`return e->representation.length;`
116			`case BT_DERIVED:`
117			`type = gfc_typenode_for_spec (&e->ts);`
118			`return int_size_in_bytes (type);`
119			`default:`
120			`gfc_internal_error ("Invalid expression in gfc_target_expr_size.");`
121			`return 0;`
122			`}`
123			`}`
124
125
126			`/* The encode_* functions export a value into a buffer, and`
127			`return the number of bytes of the buffer that have been`
128			`used. */`
129
130			`static int`
131			`encode_array (gfc_expr expr, unsigned char buffer, size_t buffer_size)`
132			`{`
133			`mpz_t array_size;`
134			`int i;`
135			`int ptr = 0;`
136
137			`gfc_array_size (expr, &array_size);`
138			`for (i = 0; i < (int)mpz_get_ui (array_size); i++)`
139			`{`
140			`ptr += gfc_target_encode_expr (gfc_get_array_element (expr, i),`
141			`&buffer[ptr], buffer_size - ptr);`
142			`}`
143
144			`mpz_clear (array_size);`
145			`return ptr;`
146			`}`
147
148
149			`static int`
150			`encode_integer (int kind, mpz_t integer, unsigned char *buffer,`
151			`size_t buffer_size)`
152			`{`
153			`return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),`
154			`buffer, buffer_size);`
155			`}`
156
157
158			`static int`
159			`encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)`
160			`{`
161			`return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind, 0), buffer,`
162			`buffer_size);`
163			`}`
164
165
166			`static int`
167			`encode_complex (int kind, mpc_t cmplx,`
168			`unsigned char *buffer, size_t buffer_size)`
169			`{`
170			`int size;`
171			`size = encode_float (kind, mpc_realref (cmplx), &buffer[0], buffer_size);`
172			`size += encode_float (kind, mpc_imagref (cmplx),`
173			`&buffer[size], buffer_size - size);`
174			`return size;`
175			`}`
176
177
178			`static int`
179			`encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)`
180			`{`
181			`return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),`
182			`logical),`
183			`buffer, buffer_size);`
184			`}`
185
186
187			`int`
188			`gfc_encode_character (int kind, int length, const gfc_char_t *string,`
189			`unsigned char *buffer, size_t buffer_size)`
190			`{`
191			`size_t elsize = size_character (1, kind);`
192			`tree type = gfc_get_char_type (kind);`
193			`int i;`
194
195			`gcc_assert (buffer_size >= size_character (length, kind));`
196
197			`for (i = 0; i < length; i++)`
198			`native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize],`
199			`elsize);`
200
201			`return length;`
202			`}`
203
204
205			`static int`
206			`encode_derived (gfc_expr source, unsigned char buffer, size_t buffer_size)`
207			`{`
208			`gfc_constructor *ctr;`
209			`gfc_component *cmp;`
210			`int ptr;`
211			`tree type;`
212
213			`type = gfc_typenode_for_spec (&source->ts);`
214
215			`ctr = source->value.constructor;`
216			`cmp = source->ts.u.derived->components;`
217			`for (;ctr; ctr = ctr->next, cmp = cmp->next)`
218			`{`
219			`gcc_assert (cmp);`
220			`if (!ctr->expr)`
221			`continue;`
222			`ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))`
223			`+ TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;`
224
225			`if (ctr->expr->expr_type == EXPR_NULL)`
226			`memset (&buffer[ptr], 0,`
227			`int_size_in_bytes (TREE_TYPE (cmp->backend_decl)));`
228			`else`
229			`gfc_target_encode_expr (ctr->expr, &buffer[ptr],`
230			`buffer_size - ptr);`
231			`}`
232
233			`return int_size_in_bytes (type);`
234			`}`
235
236
237			`/* Write a constant expression in binary form to a buffer. */`
238			`int`
239			`gfc_target_encode_expr (gfc_expr source, unsigned char buffer,`
240			`size_t buffer_size)`
241			`{`
242			`if (source == NULL)`
243			`return 0;`
244
245			`if (source->expr_type == EXPR_ARRAY)`
246			`return encode_array (source, buffer, buffer_size);`
247
248			`gcc_assert (source->expr_type == EXPR_CONSTANT`
249			`\|\| source->expr_type == EXPR_STRUCTURE`
250			`\|\| source->expr_type == EXPR_SUBSTRING);`
251
252			`/* If we already have a target-memory representation, we use that rather`
253			`than recreating one. */`
254			`if (source->representation.string)`
255			`{`
256			`memcpy (buffer, source->representation.string,`
257			`source->representation.length);`
258			`return source->representation.length;`
259			`}`
260
261			`switch (source->ts.type)`
262			`{`
263			`case BT_INTEGER:`
264			`return encode_integer (source->ts.kind, source->value.integer, buffer,`
265			`buffer_size);`
266			`case BT_REAL:`
267			`return encode_float (source->ts.kind, source->value.real, buffer,`
268			`buffer_size);`
269			`case BT_COMPLEX:`
270			`return encode_complex (source->ts.kind, source->value.complex,`
271			`buffer, buffer_size);`
272			`case BT_LOGICAL:`
273			`return encode_logical (source->ts.kind, source->value.logical, buffer,`
274			`buffer_size);`
275			`case BT_CHARACTER:`
276			`if (source->expr_type == EXPR_CONSTANT \|\| source->ref == NULL)`
277			`return gfc_encode_character (source->ts.kind,`
278			`source->value.character.length,`
279			`source->value.character.string,`
280			`buffer, buffer_size);`
281			`else`
282			`{`
283			`int start, end;`
284
285			`gcc_assert (source->expr_type == EXPR_SUBSTRING);`
286			`gfc_extract_int (source->ref->u.ss.start, &start);`
287			`gfc_extract_int (source->ref->u.ss.end, &end);`
288			`return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0),`
289			`&source->value.character.string[start-1],`
290			`buffer, buffer_size);`
291			`}`
292
293			`case BT_DERIVED:`
294			`return encode_derived (source, buffer, buffer_size);`
295			`default:`
296			`gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");`
297			`return 0;`
298			`}`
299			`}`
300
301
302			`static int`
303			`interpret_array (unsigned char buffer, size_t buffer_size, gfc_expr result)`
304			`{`
305			`int array_size = 1;`
306			`int i;`
307			`int ptr = 0;`
308			`gfc_constructor head = NULL, tail = NULL;`
309
310			`/* Calculate array size from its shape and rank. */`
311			`gcc_assert (result->rank > 0 && result->shape);`
312
313			`for (i = 0; i < result->rank; i++)`
314			`array_size *= (int)mpz_get_ui (result->shape[i]);`
315
316			`/* Iterate over array elements, producing constructors. */`
317			`for (i = 0; i < array_size; i++)`
318			`{`
319			`if (head == NULL)`
320			`head = tail = gfc_get_constructor ();`
321			`else`
322			`{`
323			`tail->next = gfc_get_constructor ();`
324			`tail = tail->next;`
325			`}`
326
327			`tail->where = result->where;`
328			`tail->expr = gfc_constant_result (result->ts.type,`
329			`result->ts.kind, &result->where);`
330			`tail->expr->ts = result->ts;`
331
332			`if (tail->expr->ts.type == BT_CHARACTER)`
333			`tail->expr->value.character.length = result->value.character.length;`
334
335			`ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,`
336			`tail->expr);`
337			`}`
338			`result->value.constructor = head;`
339
340			`return ptr;`
341			`}`
342
343
344			`int`
345			`gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,`
346			`mpz_t integer)`
347			`{`
348			`mpz_init (integer);`
349			`gfc_conv_tree_to_mpz (integer,`
350			`native_interpret_expr (gfc_get_int_type (kind),`
351			`buffer, buffer_size));`
352			`return size_integer (kind);`
353			`}`
354
355
356			`int`
357			`gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,`
358			`mpfr_t real)`
359			`{`
360			`gfc_set_model_kind (kind);`
361			`mpfr_init (real);`
362			`gfc_conv_tree_to_mpfr (real,`
363			`native_interpret_expr (gfc_get_real_type (kind),`
364			`buffer, buffer_size));`
365
366			`return size_float (kind);`
367			`}`
368
369
370			`int`
371			`gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,`
372			`mpc_t complex)`
373			`{`
374			`int size;`
375			`size = gfc_interpret_float (kind, &buffer[0], buffer_size,`
376			`mpc_realref (complex));`
377			`size += gfc_interpret_float (kind, &buffer[size], buffer_size - size,`
378			`mpc_imagref (complex));`
379			`return size;`
380			`}`
381
382
383			`int`
384			`gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,`
385			`int *logical)`
386			`{`
387			`tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,`
388			`buffer_size);`
389			`*logical = double_int_zero_p (tree_to_double_int (t))`
390			`? 0 : 1;`
391			`return size_logical (kind);`
392			`}`
393
394
395			`int`
396			`gfc_interpret_character (unsigned char *buffer, size_t buffer_size,`
397			`gfc_expr *result)`
398			`{`
399			`int i;`
400
401			`if (result->ts.u.cl && result->ts.u.cl->length)`
402			`result->value.character.length =`
403			`(int) mpz_get_ui (result->ts.u.cl->length->value.integer);`
404
405			`gcc_assert (buffer_size >= size_character (result->value.character.length,`
406			`result->ts.kind));`
407			`result->value.character.string =`
408			`gfc_get_wide_string (result->value.character.length + 1);`
409
410			`if (result->ts.kind == gfc_default_character_kind)`
411			`for (i = 0; i < result->value.character.length; i++)`
412			`result->value.character.string[i] = (gfc_char_t) buffer[i];`
413			`else`
414			`{`
415			`mpz_t integer;`
416			`unsigned bytes = size_character (1, result->ts.kind);`
417			`mpz_init (integer);`
418			`gcc_assert (bytes <= sizeof (unsigned long));`
419
420			`for (i = 0; i < result->value.character.length; i++)`
421			`{`
422			`gfc_conv_tree_to_mpz (integer,`
423			`native_interpret_expr (gfc_get_char_type (result->ts.kind),`
424			`&buffer[bytesi], buffer_size-bytesi));`
425			`result->value.character.string[i]`
426			`= (gfc_char_t) mpz_get_ui (integer);`
427			`}`
428
429			`mpz_clear (integer);`
430			`}`
431
432			`result->value.character.string[result->value.character.length] = '\0';`
433
434			`return result->value.character.length;`
435			`}`
436
437
438			`int`
439			`gfc_interpret_derived (unsigned char buffer, size_t buffer_size, gfc_expr result)`
440			`{`
441			`gfc_component *cmp;`
442			`gfc_constructor head = NULL, tail = NULL;`
443			`int ptr;`
444			`tree type;`
445
446			`/* The attributes of the derived type need to be bolted to the floor. */`
447			`result->expr_type = EXPR_STRUCTURE;`
448
449			`type = gfc_typenode_for_spec (&result->ts);`
450			`cmp = result->ts.u.derived->components;`
451
452			`/* Run through the derived type components. */`
453			`for (;cmp; cmp = cmp->next)`
454			`{`
455			`if (head == NULL)`
456			`head = tail = gfc_get_constructor ();`
457			`else`
458			`{`
459			`tail->next = gfc_get_constructor ();`
460			`tail = tail->next;`
461			`}`
462
463			`/* The constructor points to the component. */`
464			`tail->n.component = cmp;`
465
466			`tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind,`
467			`&result->where);`
468			`tail->expr->ts = cmp->ts;`
469
470			`/* Copy shape, if needed. */`
471			`if (cmp->as && cmp->as->rank)`
472			`{`
473			`int n;`
474
475			`tail->expr->expr_type = EXPR_ARRAY;`
476			`tail->expr->rank = cmp->as->rank;`
477
478			`tail->expr->shape = gfc_get_shape (tail->expr->rank);`
479			`for (n = 0; n < tail->expr->rank; n++)`
480			`{`
481			`mpz_init_set_ui (tail->expr->shape[n], 1);`
482			`mpz_add (tail->expr->shape[n], tail->expr->shape[n],`
483			`cmp->as->upper[n]->value.integer);`
484			`mpz_sub (tail->expr->shape[n], tail->expr->shape[n],`
485			`cmp->as->lower[n]->value.integer);`
486			`}`
487			`}`
488
489			`ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));`
490			`gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,`
491			`tail->expr);`
492
493			`result->value.constructor = head;`
494			`}`
495
496			`return int_size_in_bytes (type);`
497			`}`
498
499
500			`/* Read a binary buffer to a constant expression. */`
501			`int`
502			`gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,`
503			`gfc_expr *result)`
504			`{`
505			`if (result->expr_type == EXPR_ARRAY)`
506			`return interpret_array (buffer, buffer_size, result);`
507
508			`switch (result->ts.type)`
509			`{`
510			`case BT_INTEGER:`
511			`result->representation.length =`
512			`gfc_interpret_integer (result->ts.kind, buffer, buffer_size,`
513			`result->value.integer);`
514			`break;`
515
516			`case BT_REAL:`
517			`result->representation.length =`
518			`gfc_interpret_float (result->ts.kind, buffer, buffer_size,`
519			`result->value.real);`
520			`break;`
521
522			`case BT_COMPLEX:`
523			`result->representation.length =`
524			`gfc_interpret_complex (result->ts.kind, buffer, buffer_size,`
525			`result->value.complex);`
526			`break;`
527
528			`case BT_LOGICAL:`
529			`result->representation.length =`
530			`gfc_interpret_logical (result->ts.kind, buffer, buffer_size,`
531			`&result->value.logical);`
532			`break;`
533
534			`case BT_CHARACTER:`
535			`result->representation.length =`
536			`gfc_interpret_character (buffer, buffer_size, result);`
537			`break;`
538
539			`case BT_DERIVED:`
540			`result->representation.length =`
541			`gfc_interpret_derived (buffer, buffer_size, result);`
542			`break;`
543
544			`default:`
545			`gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");`
546			`break;`
547			`}`
548
549			`if (result->ts.type == BT_CHARACTER)`
550			`result->representation.string`
551			`= gfc_widechar_to_char (result->value.character.string,`
552			`result->value.character.length);`
553			`else`
554			`{`
555			`result->representation.string =`
556			`(char *) gfc_getmem (result->representation.length + 1);`
557			`memcpy (result->representation.string, buffer,`
558			`result->representation.length);`
559			`result->representation.string[result->representation.length] = '\0';`
560			`}`
561
562			`return result->representation.length;`
563			`}`
564
565
566			`/* --------------------------------------------------------------- */`
567			`/* Two functions used by trans-common.c to write overlapping`
568			`equivalence initializers to a buffer. This is added to the union`
569			`and the original initializers freed. */`
570
571
572			`/* Writes the values of a constant expression to a char buffer. If another`
573			`unequal initializer has already been written to the buffer, this is an`
574			`error. */`
575
576			`static size_t`
577			`expr_to_char (gfc_expr e, unsigned char data, unsigned char *chk, size_t len)`
578			`{`
579			`int i;`
580			`int ptr;`
581			`gfc_constructor *ctr;`
582			`gfc_component *cmp;`
583			`unsigned char *buffer;`
584
585			`if (e == NULL)`
586			`return 0;`
587
588			`/* Take a derived type, one component at a time, using the offsets from the backend`
589			`declaration. */`
590			`if (e->ts.type == BT_DERIVED)`
591			`{`
592			`ctr = e->value.constructor;`
593			`cmp = e->ts.u.derived->components;`
594			`for (;ctr; ctr = ctr->next, cmp = cmp->next)`
595			`{`
596			`gcc_assert (cmp && cmp->backend_decl);`
597			`if (!ctr->expr)`
598			`continue;`
599			`ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))`
600			`+ TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;`
601			`expr_to_char (ctr->expr, &data[ptr], &chk[ptr], len);`
602			`}`
603			`return len;`
604			`}`
605
606			`/* Otherwise, use the target-memory machinery to write a bitwise image, appropriate`
607			`to the target, in a buffer and check off the initialized part of the buffer. */`
608			`len = gfc_target_expr_size (e);`
609			`buffer = (unsigned char*)alloca (len);`
610			`len = gfc_target_encode_expr (e, buffer, len);`
611
612			`for (i = 0; i < (int)len; i++)`
613			`{`
614			`if (chk[i] && (buffer[i] != data[i]))`
615			`{`
616			`gfc_error ("Overlapping unequal initializers in EQUIVALENCE "`
617			`"at %L", &e->where);`
618			`return 0;`
619			`}`
620			`chk[i] = 0xFF;`
621			`}`
622
623			`memcpy (data, buffer, len);`
624			`return len;`
625			`}`
626
627
628			`/* Writes the values from the equivalence initializers to a char* array`
629			`that will be written to the constructor to make the initializer for`
630			`the union declaration. */`
631
632			`size_t`
633			`gfc_merge_initializers (gfc_typespec ts, gfc_expr e, unsigned char data,`
634			`unsigned char *chk, size_t length)`
635			`{`
636			`size_t len = 0;`
637			`gfc_constructor * c;`
638
639			`switch (e->expr_type)`
640			`{`
641			`case EXPR_CONSTANT:`
642			`case EXPR_STRUCTURE:`
643			`len = expr_to_char (e, &data[0], &chk[0], length);`
644
645			`break;`
646
647			`case EXPR_ARRAY:`
648			`for (c = e->value.constructor; c; c = c->next)`
649			`{`
650			`size_t elt_size = gfc_target_expr_size (c->expr);`
651
652			`if (c->n.offset)`
653			`len = elt_size * (size_t)mpz_get_si (c->n.offset);`
654
655			`len = len + gfc_merge_initializers (ts, c->expr, &data[len],`
656			`&chk[len], length - len);`
657			`}`
658			`break;`
659
660			`default:`
661			`return 0;`
662			`}`
663
664			`return len;`
665			`}`
666
667
668			`/* Transfer the bitpattern of a (integer) BOZ to real or complex variables.`
669			`When successful, no BOZ or nothing to do, true is returned. */`
670
671			`bool`
672			`gfc_convert_boz (gfc_expr expr, gfc_typespec ts)`
673			`{`
674			`size_t buffer_size, boz_bit_size, ts_bit_size;`
675			`int index;`
676			`unsigned char *buffer;`
677
678			`if (!expr->is_boz)`
679			`return true;`
680
681			`gcc_assert (expr->expr_type == EXPR_CONSTANT`
682			`&& expr->ts.type == BT_INTEGER);`
683
684			`/* Don't convert BOZ to logical, character, derived etc. */`
685			`if (ts->type == BT_REAL)`
686			`{`
687			`buffer_size = size_float (ts->kind);`
688			`ts_bit_size = buffer_size * 8;`
689			`}`
690			`else if (ts->type == BT_COMPLEX)`
691			`{`
692			`buffer_size = size_complex (ts->kind);`
693			`ts_bit_size = buffer_size * 8 / 2;`
694			`}`
695			`else`
696			`return true;`
697
698			`/* Convert BOZ to the smallest possible integer kind. */`
699			`boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);`
700
701			`if (boz_bit_size > ts_bit_size)`
702			`{`
703			`gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",`
704			`&expr->where, (long) boz_bit_size, (long) ts_bit_size);`
705			`return false;`
706			`}`
707
708			`for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)`
709			`if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)`
710			`break;`
711
712			`expr->ts.kind = gfc_integer_kinds[index].kind;`
713			`buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));`
714
715			`buffer = (unsigned char*)alloca (buffer_size);`
716			`encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);`
717			`mpz_clear (expr->value.integer);`
718
719			`if (ts->type == BT_REAL)`
720			`{`
721			`mpfr_init (expr->value.real);`
722			`gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);`
723			`}`
724			`else`
725			`{`
726			`mpc_init2 (expr->value.complex, mpfr_get_default_prec());`
727			`gfc_interpret_complex (ts->kind, buffer, buffer_size,`
728			`expr->value.complex);`
729			`}`
730			`expr->is_boz = 0;`
731			`expr->ts.type = ts->type;`
732			`expr->ts.kind = ts->kind;`
733
734			`return true;`
735			`}`