trans-types.c

gcc-fortran,linux使用fortran的编译软件。很好用的。

#ifdef SIZE_TYPE  
  if (strcmp (SIZE_TYPE, "unsigned int") == 0)
    return INT_TYPE_SIZE;
  if (strcmp (SIZE_TYPE, "long unsigned int") == 0)
    return LONG_TYPE_SIZE;
  if (strcmp (SIZE_TYPE, "short unsigned int") == 0)
    return SHORT_TYPE_SIZE;
  gcc_unreachable ();
#else
  return LONG_TYPE_SIZE;
#endif
}
#endif

/* Create the backend type nodes. We map them to their
   equivalent C type, at least for now.  We also give
   names to the types here, and we push them in the
   global binding level context.*/

void
gfc_init_types (void)
{
  char name_buf[16];
  int index;
  tree type;
  unsigned n;
  unsigned HOST_WIDE_INT hi;
  unsigned HOST_WIDE_INT lo;

  /* Create and name the types.  */
#define PUSH_TYPE(name, node) \
  pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))

  for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
    {
      type = gfc_build_int_type (&gfc_integer_kinds[index]);
      gfc_integer_types[index] = type;
      snprintf (name_buf, sizeof(name_buf), "int%d",
		gfc_integer_kinds[index].kind);
      PUSH_TYPE (name_buf, type);
    }

  for (index = 0; gfc_logical_kinds[index].kind != 0; ++index)
    {
      type = gfc_build_logical_type (&gfc_logical_kinds[index]);
      gfc_logical_types[index] = type;
      snprintf (name_buf, sizeof(name_buf), "logical%d",
		gfc_logical_kinds[index].kind);
      PUSH_TYPE (name_buf, type);
    }

  for (index = 0; gfc_real_kinds[index].kind != 0; index++)
    {
      type = gfc_build_real_type (&gfc_real_kinds[index]);
      gfc_real_types[index] = type;
      snprintf (name_buf, sizeof(name_buf), "real%d",
		gfc_real_kinds[index].kind);
      PUSH_TYPE (name_buf, type);

      type = gfc_build_complex_type (type);
      gfc_complex_types[index] = type;
      snprintf (name_buf, sizeof(name_buf), "complex%d",
		gfc_real_kinds[index].kind);
      PUSH_TYPE (name_buf, type);
    }

  gfc_character1_type_node = build_type_variant (unsigned_char_type_node, 
						 0, 0);
  PUSH_TYPE ("char", gfc_character1_type_node);

  PUSH_TYPE ("byte", unsigned_char_type_node);
  PUSH_TYPE ("void", void_type_node);

  /* DBX debugging output gets upset if these aren't set.  */
  if (!TYPE_NAME (integer_type_node))
    PUSH_TYPE ("c_integer", integer_type_node);
  if (!TYPE_NAME (char_type_node))
    PUSH_TYPE ("c_char", char_type_node);

#undef PUSH_TYPE

  pvoid_type_node = build_pointer_type (void_type_node);
  ppvoid_type_node = build_pointer_type (pvoid_type_node);
  pchar_type_node = build_pointer_type (gfc_character1_type_node);

  gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
  /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
     since this function is called before gfc_init_constants.  */
  gfc_array_range_type
	  = build_range_type (gfc_array_index_type,
			      build_int_cst (gfc_array_index_type, 0),
			      NULL_TREE);

  /* The maximum array element size that can be handled is determined
     by the number of bits available to store this field in the array
     descriptor.  */

  n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;
  lo = ~ (unsigned HOST_WIDE_INT) 0;
  if (n > HOST_BITS_PER_WIDE_INT)
    hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);
  else
    hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;
  gfc_max_array_element_size
    = build_int_cst_wide (long_unsigned_type_node, lo, hi);

  size_type_node = gfc_array_index_type;

  boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);
  boolean_true_node = build_int_cst (boolean_type_node, 1);
  boolean_false_node = build_int_cst (boolean_type_node, 0);

  /* ??? Shouldn't this be based on gfc_index_integer_kind or so?  */
  gfc_charlen_type_node = gfc_get_int_type (4);
}

/* Get the type node for the given type and kind.  */

tree
gfc_get_int_type (int kind)
{
  int index = gfc_validate_kind (BT_INTEGER, kind, true);
  return index < 0 ? 0 : gfc_integer_types[index];
}

tree
gfc_get_real_type (int kind)
{
  int index = gfc_validate_kind (BT_REAL, kind, true);
  return index < 0 ? 0 : gfc_real_types[index];
}

tree
gfc_get_complex_type (int kind)
{
  int index = gfc_validate_kind (BT_COMPLEX, kind, true);
  return index < 0 ? 0 : gfc_complex_types[index];
}

tree
gfc_get_logical_type (int kind)
{
  int index = gfc_validate_kind (BT_LOGICAL, kind, true);
  return index < 0 ? 0 : gfc_logical_types[index];
}

/* Create a character type with the given kind and length.  */

tree
gfc_get_character_type_len (int kind, tree len)
{
  tree bounds, type;

  gfc_validate_kind (BT_CHARACTER, kind, false);

  bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
  type = build_array_type (gfc_character1_type_node, bounds);
  TYPE_STRING_FLAG (type) = 1;

  return type;
}


/* Get a type node for a character kind.  */

tree
gfc_get_character_type (int kind, gfc_charlen * cl)
{
  tree len;

  len = (cl == NULL) ? NULL_TREE : cl->backend_decl;

  return gfc_get_character_type_len (kind, len);
}

/* Covert a basic type.  This will be an array for character types.  */

tree
gfc_typenode_for_spec (gfc_typespec * spec)
{
  tree basetype;

  switch (spec->type)
    {
    case BT_UNKNOWN:
      gcc_unreachable ();

    case BT_INTEGER:
      basetype = gfc_get_int_type (spec->kind);
      break;

    case BT_REAL:
      basetype = gfc_get_real_type (spec->kind);
      break;

    case BT_COMPLEX:
      basetype = gfc_get_complex_type (spec->kind);
      break;

    case BT_LOGICAL:
      basetype = gfc_get_logical_type (spec->kind);
      break;

    case BT_CHARACTER:
      basetype = gfc_get_character_type (spec->kind, spec->cl);
      break;

    case BT_DERIVED:
      basetype = gfc_get_derived_type (spec->derived);
      break;

    default:
      gcc_unreachable ();
    }
  return basetype;
}

/* Build an INT_CST for constant expressions, otherwise return NULL_TREE.  */

static tree
gfc_conv_array_bound (gfc_expr * expr)
{
  /* If expr is an integer constant, return that.  */
  if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
    return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);

  /* Otherwise return NULL.  */
  return NULL_TREE;
}

tree
gfc_get_element_type (tree type)
{
  tree element;

  if (GFC_ARRAY_TYPE_P (type))
    {
      if (TREE_CODE (type) == POINTER_TYPE)
        type = TREE_TYPE (type);
      gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
      element = TREE_TYPE (type);
    }
  else
    {
      gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
      element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);

      gcc_assert (TREE_CODE (element) == POINTER_TYPE);
      element = TREE_TYPE (element);

      gcc_assert (TREE_CODE (element) == ARRAY_TYPE);
      element = TREE_TYPE (element);
    }

  return element;
}

/* Build an array. This function is called from gfc_sym_type().
   Actually returns array descriptor type.

   Format of array descriptors is as follows:

    struct gfc_array_descriptor
    {
      array *data
      index offset;
      index dtype;
      struct descriptor_dimension dimension[N_DIM];
    }

    struct descriptor_dimension
    {
      index stride;
      index lbound;
      index ubound;
    }

   Translation code should use gfc_conv_descriptor_* rather than accessing
   the descriptor directly. Any changes to the array descriptor type will
   require changes in gfc_conv_descriptor_* and gfc_build_array_initializer.

   This is represented internally as a RECORD_TYPE. The index nodes are
   gfc_array_index_type and the data node is a pointer to the data. See below
   for the handling of character types.

   The dtype member is formatted as follows:
    rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
    type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
    size = dtype >> GFC_DTYPE_SIZE_SHIFT

   I originally used nested ARRAY_TYPE nodes to represent arrays, but this
   generated poor code for assumed/deferred size arrays.  These require
   use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of the GENERIC
   grammar.  Also, there is no way to explicitly set the array stride, so
   all data must be packed(1).  I've tried to mark all the functions which
   would require modification with a GCC ARRAYS comment.

   The data component points to the first element in the array.
   The offset field is the position of the origin of the array
   (ie element (0, 0 ...)).  This may be outsite the bounds of the array.

   An element is accessed by
   data[offset + index0*stride0 + index1*stride1 + index2*stride2]
   This gives good performance as the computation does not involve the
   bounds of the array.  For packed arrays, this is optimized further by
   substituting the known strides.

   This system has one problem: all array bounds must be withing 2^31 elements
   of the origin (2^63 on 64-bit machines).  For example
   integer, dimension (80000:90000, 80000:90000, 2) :: array
   may not work properly on 32-bit machines because 80000*80000 > 2^31, so
   the calculation for stride02 would overflow.  This may still work, but
   I haven't checked, and it relies on the overflow doing the right thing.

   The way to fix this problem is to access elements as follows:
   data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
   Obviously this is much slower.  I will make this a compile time option,
   something like -fsmall-array-offsets.  Mixing code compiled with and without
   this switch will work.

   (1) This can be worked around by modifying the upper bound of the previous
   dimension.  This requires extra fields in the descriptor (both real_ubound
   and fake_ubound).  In tree.def there is mention of TYPE_SEP, which
   may allow us to do this.  However I can't find mention of this anywhere
   else.  */


/* Returns true if the array sym does not require a descriptor.  */

int
gfc_is_nodesc_array (gfc_symbol * sym)
{
  gcc_assert (sym->attr.dimension);

  /* We only want local arrays.  */
  if (sym->attr.pointer || sym->attr.allocatable)
    return 0;

  if (sym->attr.dummy)
    {
      if (sym->as->type != AS_ASSUMED_SHAPE)
        return 1;
      else
        return 0;
    }

  if (sym->attr.result || sym->attr.function)
    return 0;

  gcc_assert (sym->as->type == AS_EXPLICIT);

  return 1;
}


/* Create an array descriptor type.  */

static tree
gfc_build_array_type (tree type, gfc_array_spec * as)
{
  tree lbound[GFC_MAX_DIMENSIONS];
  tree ubound[GFC_MAX_DIMENSIONS];
  int n;

  for (n = 0; n < as->rank; n++)
    {
      /* Create expressions for the known bounds of the array.  */
      if (as->type == AS_ASSUMED_SHAPE && as->lower[n] == NULL)
        lbound[n] = gfc_index_one_node;
      else
        lbound[n] = gfc_conv_array_bound (as->lower[n]);
      ubound[n] = gfc_conv_array_bound (as->upper[n]);
    }

  return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
}

/* Returns the struct descriptor_dimension type.  */

static tree
gfc_get_desc_dim_type (void)
{
  tree type;
  tree decl;
  tree fieldlist;

  if (gfc_desc_dim_type)
    return gfc_desc_dim_type;

  /* Build the type node.  */
  type = make_node (RECORD_TYPE);

  TYPE_NAME (type) = get_identifier ("descriptor_dimension");
  TYPE_PACKED (type) = 1;

  /* Consists of the stride, lbound and ubound members.  */
  decl = build_decl (FIELD_DECL,
		     get_identifier ("stride"), gfc_array_index_type);
  DECL_CONTEXT (decl) = type;
  fieldlist = decl;

  decl = build_decl (FIELD_DECL,
		     get_identifier ("lbound"), gfc_array_index_type);
  DECL_CONTEXT (decl) = type;
  fieldlist = chainon (fieldlist, decl);

  decl = build_decl (FIELD_DECL,
		     get_identifier ("ubound"), gfc_array_index_type);
  DECL_CONTEXT (decl) = type;
  fieldlist = chainon (fieldlist, decl);

  /* Finish off the type.  */
  TYPE_FIELDS (type) = fieldlist;

  gfc_finish_type (type);

  gfc_desc_dim_type = type;
  return type;
}


/* Return the DTYPE for an array.  This describes the type and type parameters
   of the array.  */
/* TODO: Only call this when the value is actually used, and make all the
   unknown cases abort.  */

tree
gfc_get_dtype (tree type)
{
  tree size;
  int n;
  HOST_WIDE_INT i;
  tree tmp;
  tree dtype;
  tree etype;
  int rank;

  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));

  if (GFC_TYPE_ARRAY_DTYPE (type))
    return GFC_TYPE_ARRAY_DTYPE (type);

  rank = GFC_TYPE_ARRAY_RANK (type);
  etype = gfc_get_element_type (type);

  switch (TREE_CODE (etype))
    {
    case INTEGER_TYPE:
      n = GFC_DTYPE_INTEGER;
      break;

    case BOOLEAN_TYPE:
      n = GFC_DTYPE_LOGICAL;
      break;

    case REAL_TYPE:
      n = GFC_DTYPE_REAL;
      break;

    case COMPLEX_TYPE:
      n = GFC_DTYPE_COMPLEX;
      break;

    /* We will never have arrays of arrays.  */