#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "tm.h"
#include "target.h"
#include "ggc.h"
#include "toplev.h"
#include "gfortran.h"
#include "trans.h"
#include "trans-types.h"
#include "trans-const.h"
#include "real.h"
#if (GFC_MAX_DIMENSIONS < 10)
#define GFC_RANK_DIGITS 1
#define GFC_RANK_PRINTF_FORMAT "%01d"
#elif (GFC_MAX_DIMENSIONS < 100)
#define GFC_RANK_DIGITS 2
#define GFC_RANK_PRINTF_FORMAT "%02d"
#else
#error If you really need >99 dimensions, continue the sequence above...
#endif
static tree gfc_get_derived_type (gfc_symbol * derived);
tree gfc_array_index_type;
tree pvoid_type_node;
tree ppvoid_type_node;
tree pchar_type_node;
tree gfc_character1_type_node;
tree gfc_charlen_type_node;
static GTY(()) tree gfc_desc_dim_type;
static GTY(()) tree gfc_max_array_element_size;
#define MAX_INT_KINDS 5
gfc_integer_info gfc_integer_kinds[MAX_INT_KINDS + 1];
gfc_logical_info gfc_logical_kinds[MAX_INT_KINDS + 1];
static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1];
static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];
#define MAX_REAL_KINDS 4
gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];
static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];
static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];
int gfc_index_integer_kind;
int gfc_default_integer_kind;
int gfc_max_integer_kind;
int gfc_default_real_kind;
int gfc_default_double_kind;
int gfc_default_character_kind;
int gfc_default_logical_kind;
int gfc_default_complex_kind;
int gfc_c_int_kind;
void
gfc_init_kinds (void)
{
enum machine_mode mode;
int i_index, r_index;
bool saw_i4 = false, saw_i8 = false;
bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)
{
int kind, bitsize;
if (!targetm.scalar_mode_supported_p (mode))
continue;
bitsize = GET_MODE_BITSIZE (mode);
if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
continue;
gcc_assert (i_index != MAX_INT_KINDS);
kind = bitsize / 8;
if (kind == 4)
saw_i4 = true;
if (kind == 8)
saw_i8 = true;
gfc_integer_kinds[i_index].kind = kind;
gfc_integer_kinds[i_index].radix = 2;
gfc_integer_kinds[i_index].digits = bitsize - 1;
gfc_integer_kinds[i_index].bit_size = bitsize;
gfc_logical_kinds[i_index].kind = kind;
gfc_logical_kinds[i_index].bit_size = bitsize;
i_index += 1;
}
gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
{
const struct real_format *fmt = REAL_MODE_FORMAT (mode);
int kind;
if (fmt == NULL)
continue;
if (!targetm.scalar_mode_supported_p (mode))
continue;
kind = (GET_MODE_PRECISION (mode) + 7) / 8;
if (kind == 4)
saw_r4 = true;
if (kind == 8)
saw_r8 = true;
if (kind == 16)
saw_r16 = true;
gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
gcc_assert (r_index != MAX_REAL_KINDS);
gfc_real_kinds[r_index].kind = kind;
gfc_real_kinds[r_index].radix = fmt->b;
gfc_real_kinds[r_index].digits = fmt->p;
gfc_real_kinds[r_index].min_exponent = fmt->emin;
gfc_real_kinds[r_index].max_exponent = fmt->emax;
gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
r_index += 1;
}
if (gfc_option.flag_default_integer)
{
if (!saw_i8)
fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
gfc_default_integer_kind = 8;
}
else if (saw_i4)
gfc_default_integer_kind = 4;
else
gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
if (gfc_option.flag_default_real)
{
if (!saw_r8)
fatal_error ("real kind=8 not available for -fdefault-real-8 option");
gfc_default_real_kind = 8;
}
else if (saw_r4)
gfc_default_real_kind = 4;
else
gfc_default_real_kind = gfc_real_kinds[0].kind;
if (gfc_option.flag_default_double && !gfc_option.flag_default_real)
fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8)
gfc_default_double_kind = 8;
else if (gfc_option.flag_default_real && saw_r16)
gfc_default_double_kind = 16;
else if (saw_r4 && saw_r8)
gfc_default_double_kind = 8;
else
{
gfc_default_double_kind
= gfc_validate_kind (BT_REAL, gfc_default_real_kind * 2, false);
}
gfc_default_logical_kind = gfc_default_integer_kind;
gfc_default_complex_kind = gfc_default_real_kind;
gfc_default_character_kind = gfc_integer_kinds[0].kind;
gfc_index_integer_kind = POINTER_SIZE / 8;
gfc_c_int_kind = INT_TYPE_SIZE / 8;
}
static int
validate_integer (int kind)
{
int i;
for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
if (gfc_integer_kinds[i].kind == kind)
return i;
return -1;
}
static int
validate_real (int kind)
{
int i;
for (i = 0; gfc_real_kinds[i].kind != 0; i++)
if (gfc_real_kinds[i].kind == kind)
return i;
return -1;
}
static int
validate_logical (int kind)
{
int i;
for (i = 0; gfc_logical_kinds[i].kind; i++)
if (gfc_logical_kinds[i].kind == kind)
return i;
return -1;
}
static int
validate_character (int kind)
{
return kind == gfc_default_character_kind ? 0 : -1;
}
int
gfc_validate_kind (bt type, int kind, bool may_fail)
{
int rc;
switch (type)
{
case BT_REAL:
case BT_COMPLEX:
rc = validate_real (kind);
break;
case BT_INTEGER:
rc = validate_integer (kind);
break;
case BT_LOGICAL:
rc = validate_logical (kind);
break;
case BT_CHARACTER:
rc = validate_character (kind);
break;
default:
gfc_internal_error ("gfc_validate_kind(): Got bad type");
}
if (rc < 0 && !may_fail)
gfc_internal_error ("gfc_validate_kind(): Got bad kind");
return rc;
}
static tree
gfc_build_int_type (gfc_integer_info *info)
{
int mode_precision = info->bit_size;
if (mode_precision == CHAR_TYPE_SIZE)
info->c_char = 1;
if (mode_precision == SHORT_TYPE_SIZE)
info->c_short = 1;
if (mode_precision == INT_TYPE_SIZE)
info->c_int = 1;
if (mode_precision == LONG_TYPE_SIZE)
info->c_long = 1;
if (mode_precision == LONG_LONG_TYPE_SIZE)
info->c_long_long = 1;
if (TYPE_PRECISION (intQI_type_node) == mode_precision)
return intQI_type_node;
if (TYPE_PRECISION (intHI_type_node) == mode_precision)
return intHI_type_node;
if (TYPE_PRECISION (intSI_type_node) == mode_precision)
return intSI_type_node;
if (TYPE_PRECISION (intDI_type_node) == mode_precision)
return intDI_type_node;
if (TYPE_PRECISION (intTI_type_node) == mode_precision)
return intTI_type_node;
return make_signed_type (mode_precision);
}
static tree
gfc_build_real_type (gfc_real_info *info)
{
int mode_precision = info->mode_precision;
tree new_type;
if (mode_precision == FLOAT_TYPE_SIZE)
info->c_float = 1;
if (mode_precision == DOUBLE_TYPE_SIZE)
info->c_double = 1;
if (mode_precision == LONG_DOUBLE_TYPE_SIZE)
info->c_long_double = 1;
if (TYPE_PRECISION (float_type_node) == mode_precision)
return float_type_node;
if (TYPE_PRECISION (double_type_node) == mode_precision)
return double_type_node;
if (TYPE_PRECISION (long_double_type_node) == mode_precision)
return long_double_type_node;
new_type = make_node (REAL_TYPE);
TYPE_PRECISION (new_type) = mode_precision;
layout_type (new_type);
return new_type;
}
static tree
gfc_build_complex_type (tree scalar_type)
{
tree new_type;
if (scalar_type == NULL)
return NULL;
if (scalar_type == float_type_node)
return complex_float_type_node;
if (scalar_type == double_type_node)
return complex_double_type_node;
if (scalar_type == long_double_type_node)
return complex_long_double_type_node;
new_type = make_node (COMPLEX_TYPE);
TREE_TYPE (new_type) = scalar_type;
layout_type (new_type);
return new_type;
}
static tree
gfc_build_logical_type (gfc_logical_info *info)
{
int bit_size = info->bit_size;
tree new_type;
if (bit_size == BOOL_TYPE_SIZE)
{
info->c_bool = 1;
return boolean_type_node;
}
new_type = make_unsigned_type (bit_size);
TREE_SET_CODE (new_type, BOOLEAN_TYPE);
TYPE_MAX_VALUE (new_type) = build_int_cst (new_type, 1);
TYPE_PRECISION (new_type) = 1;
return new_type;
}
#if 0
static unsigned int
c_size_t_size (void)
{
#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
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;
#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);
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);
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);
gfc_charlen_type_node = gfc_get_int_type (4);
}
tree
gfc_get_int_type (int kind)
{
int index = gfc_validate_kind (BT_INTEGER, kind, false);
return gfc_integer_types[index];
}
tree
gfc_get_real_type (int kind)
{
int index = gfc_validate_kind (BT_REAL, kind, false);
return gfc_real_types[index];
}
tree
gfc_get_complex_type (int kind)
{
int index = gfc_validate_kind (BT_COMPLEX, kind, false);
return gfc_complex_types[index];
}
tree
gfc_get_logical_type (int kind)
{
int index = gfc_validate_kind (BT_LOGICAL, kind, false);
return gfc_logical_types[index];
}
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;
}
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);
}
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;
}
static tree
gfc_conv_array_bound (gfc_expr * expr)
{
if (expr != NULL && expr->expr_type == EXPR_CONSTANT)
return gfc_conv_mpz_to_tree (expr->value.integer, gfc_index_integer_kind);
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 = TREE_TYPE (TYPE_FIELDS (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;
}
int
gfc_is_nodesc_array (gfc_symbol * sym)
{
gcc_assert (sym->attr.dimension);
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;
if (sym->attr.pointer || sym->attr.allocatable)
return 0;
gcc_assert (sym->as->type == AS_EXPLICIT);
return 1;
}
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++)
{
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);
}
static tree
gfc_get_desc_dim_type (void)
{
tree type;
tree decl;
tree fieldlist;
if (gfc_desc_dim_type)
return gfc_desc_dim_type;
type = make_node (RECORD_TYPE);
TYPE_NAME (type) = get_identifier ("descriptor_dimension");
TYPE_PACKED (type) = 1;
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);
TYPE_FIELDS (type) = fieldlist;
gfc_finish_type (type);
gfc_desc_dim_type = type;
return type;
}
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;
case RECORD_TYPE:
n = GFC_DTYPE_DERIVED;
break;
case ARRAY_TYPE:
n = GFC_DTYPE_CHARACTER;
break;
default:
return gfc_index_zero_node;
}
gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
size = TYPE_SIZE_UNIT (etype);
i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
if (size && INTEGER_CST_P (size))
{
if (tree_int_cst_lt (gfc_max_array_element_size, size))
internal_error ("Array element size too big");
i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
}
dtype = build_int_cst (gfc_array_index_type, i);
if (size && !INTEGER_CST_P (size))
{
tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
tmp = fold (build2 (LSHIFT_EXPR, gfc_array_index_type, size, tmp));
dtype = fold (build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype));
}
GFC_TYPE_ARRAY_DTYPE (type) = dtype;
return dtype;
}
tree
gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
{
tree range;
tree type;
tree tmp;
int n;
int known_stride;
int known_offset;
mpz_t offset;
mpz_t stride;
mpz_t delta;
gfc_expr *expr;
mpz_init_set_ui (offset, 0);
mpz_init_set_ui (stride, 1);
mpz_init (delta);
type = make_node (ARRAY_TYPE);
GFC_ARRAY_TYPE_P (type) = 1;
TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
ggc_alloc_cleared (sizeof (struct lang_type));
known_stride = (packed != 0);
known_offset = 1;
for (n = 0; n < as->rank; n++)
{
if (known_stride)
tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
else
tmp = NULL_TREE;
GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
expr = as->lower[n];
if (expr->expr_type == EXPR_CONSTANT)
{
tmp = gfc_conv_mpz_to_tree (expr->value.integer,
gfc_index_integer_kind);
}
else
{
known_stride = 0;
tmp = NULL_TREE;
}
GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
if (known_stride)
{
mpz_mul (delta, stride, as->lower[n]->value.integer);
mpz_sub (offset, offset, delta);
}
else
known_offset = 0;
expr = as->upper[n];
if (expr && expr->expr_type == EXPR_CONSTANT)
{
tmp = gfc_conv_mpz_to_tree (expr->value.integer,
gfc_index_integer_kind);
}
else
{
tmp = NULL_TREE;
known_stride = 0;
}
GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
if (known_stride)
{
mpz_sub (delta, as->upper[n]->value.integer,
as->lower[n]->value.integer);
mpz_add_ui (delta, delta, 1);
mpz_mul (stride, stride, delta);
}
if (packed < 2)
known_stride = 0;
}
if (known_offset)
{
GFC_TYPE_ARRAY_OFFSET (type) =
gfc_conv_mpz_to_tree (offset, gfc_index_integer_kind);
}
else
GFC_TYPE_ARRAY_OFFSET (type) = NULL_TREE;
if (known_stride)
{
GFC_TYPE_ARRAY_SIZE (type) =
gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
}
else
GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
GFC_TYPE_ARRAY_RANK (type) = as->rank;
GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
NULL_TREE);
GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
build_pointer_type (build_array_type (etype, range));
if (known_stride)
{
mpz_sub_ui (stride, stride, 1);
range = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
}
else
range = NULL_TREE;
range = build_range_type (gfc_array_index_type, gfc_index_zero_node, range);
TYPE_DOMAIN (type) = range;
build_pointer_type (etype);
TREE_TYPE (type) = etype;
layout_type (type);
mpz_clear (offset);
mpz_clear (stride);
mpz_clear (delta);
if (packed < 3 || !known_stride)
{
type = build_pointer_type (type);
GFC_ARRAY_TYPE_P (type) = 1;
TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
}
return type;
}
tree
gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
tree * ubound, int packed)
{
tree fat_type, fat_pointer_type;
tree fieldlist;
tree arraytype;
tree decl;
int n;
char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
const char *typename;
tree lower;
tree upper;
tree stride;
tree tmp;
fat_type = make_node (RECORD_TYPE);
GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
ggc_alloc_cleared (sizeof (struct lang_type));
GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
tmp = TYPE_NAME (etype);
if (tmp && TREE_CODE (tmp) == TYPE_DECL)
tmp = DECL_NAME (tmp);
if (tmp)
typename = IDENTIFIER_POINTER (tmp);
else
typename = "unknown";
sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
GFC_MAX_SYMBOL_LEN, typename);
TYPE_NAME (fat_type) = get_identifier (name);
TYPE_PACKED (fat_type) = 0;
fat_pointer_type = build_pointer_type (fat_type);
if (packed != 0)
stride = gfc_index_one_node;
else
stride = NULL_TREE;
for (n = 0; n < dimen; n++)
{
GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
if (lbound)
lower = lbound[n];
else
lower = NULL_TREE;
if (lower != NULL_TREE)
{
if (INTEGER_CST_P (lower))
GFC_TYPE_ARRAY_LBOUND (fat_type, n) = lower;
else
lower = NULL_TREE;
}
upper = ubound[n];
if (upper != NULL_TREE)
{
if (INTEGER_CST_P (upper))
GFC_TYPE_ARRAY_UBOUND (fat_type, n) = upper;
else
upper = NULL_TREE;
}
if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
{
tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, upper, lower));
tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type, tmp,
gfc_index_one_node));
stride =
fold (build2 (MULT_EXPR, gfc_array_index_type, tmp, stride));
gcc_assert (INTEGER_CST_P (stride));
}
else
stride = NULL_TREE;
}
GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
arraytype =
build_array_type (etype,
build_range_type (gfc_array_index_type,
gfc_index_zero_node, NULL_TREE));
arraytype = build_pointer_type (arraytype);
GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
decl = build_decl (FIELD_DECL, get_identifier ("data"), arraytype);
DECL_CONTEXT (decl) = fat_type;
fieldlist = decl;
decl = build_decl (FIELD_DECL, get_identifier ("offset"),
gfc_array_index_type);
DECL_CONTEXT (decl) = fat_type;
fieldlist = chainon (fieldlist, decl);
decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
gfc_array_index_type);
DECL_CONTEXT (decl) = fat_type;
fieldlist = chainon (fieldlist, decl);
arraytype =
build_array_type (gfc_get_desc_dim_type (),
build_range_type (gfc_array_index_type,
gfc_index_zero_node,
gfc_rank_cst[dimen - 1]));
decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
DECL_CONTEXT (decl) = fat_type;
DECL_INITIAL (decl) = NULL_TREE;
fieldlist = chainon (fieldlist, decl);
TYPE_FIELDS (fat_type) = fieldlist;
gfc_finish_type (fat_type);
return fat_type;
}
static tree
gfc_build_pointer_type (gfc_symbol * sym, tree type)
{
if (sym->attr.dimension)
return type;
else
return build_pointer_type (type);
}
tree
gfc_sym_type (gfc_symbol * sym)
{
tree type;
int byref;
if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
return void_type_node;
if (sym->backend_decl)
{
if (sym->attr.function)
return TREE_TYPE (TREE_TYPE (sym->backend_decl));
else
return TREE_TYPE (sym->backend_decl);
}
if (sym->attr.function && sym->result)
sym = sym->result;
type = gfc_typenode_for_spec (&sym->ts);
if (sym->attr.dummy && !sym->attr.function)
byref = 1;
else
byref = 0;
if (sym->attr.dimension)
{
if (gfc_is_nodesc_array (sym))
{
if (sym->ts.type != BT_CHARACTER
|| !(sym->attr.dummy || sym->attr.function || sym->attr.result)
|| sym->ts.cl->backend_decl)
{
type = gfc_get_nodesc_array_type (type, sym->as,
byref ? 2 : 3);
byref = 0;
}
}
else
type = gfc_build_array_type (type, sym->as);
}
else
{
if (sym->attr.allocatable || sym->attr.pointer)
type = gfc_build_pointer_type (sym, type);
}
if (byref)
{
if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
type = build_pointer_type (type);
else
type = build_reference_type (type);
}
return (type);
}
void
gfc_finish_type (tree type)
{
tree decl;
decl = build_decl (TYPE_DECL, NULL_TREE, type);
TYPE_STUB_DECL (type) = decl;
layout_type (type);
rest_of_type_compilation (type, 1);
rest_of_decl_compilation (decl, 1, 0);
}
tree
gfc_add_field_to_struct (tree *fieldlist, tree context,
tree name, tree type)
{
tree decl;
decl = build_decl (FIELD_DECL, name, type);
DECL_CONTEXT (decl) = context;
DECL_INITIAL (decl) = 0;
DECL_ALIGN (decl) = 0;
DECL_USER_ALIGN (decl) = 0;
TREE_CHAIN (decl) = NULL_TREE;
*fieldlist = chainon (*fieldlist, decl);
return decl;
}
static tree
gfc_get_derived_type (gfc_symbol * derived)
{
tree typenode, field, field_type, fieldlist;
gfc_component *c;
gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
if (derived->backend_decl)
{
if (TYPE_FIELDS (derived->backend_decl))
return derived->backend_decl;
else
typenode = derived->backend_decl;
}
else
{
typenode = make_node (RECORD_TYPE);
TYPE_NAME (typenode) = get_identifier (derived->name);
TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
derived->backend_decl = typenode;
}
fieldlist = NULL_TREE;
for (c = derived->components; c; c = c->next)
{
if (c->ts.type == BT_DERIVED && c->pointer)
{
if (c->ts.derived->backend_decl)
field_type = c->ts.derived->backend_decl;
else
field_type = gfc_get_derived_type (c->ts.derived);
}
else
{
if (c->ts.type == BT_CHARACTER)
{
gfc_conv_const_charlen (c->ts.cl);
gcc_assert (c->ts.cl->backend_decl);
}
field_type = gfc_typenode_for_spec (&c->ts);
}
if (c->dimension)
{
if (c->pointer)
{
field_type = gfc_build_array_type (field_type, c->as);
}
else
field_type = gfc_get_nodesc_array_type (field_type, c->as, 3);
}
else if (c->pointer)
field_type = build_pointer_type (field_type);
field = gfc_add_field_to_struct (&fieldlist, typenode,
get_identifier (c->name),
field_type);
DECL_PACKED (field) |= TYPE_PACKED (typenode);
gcc_assert (!c->backend_decl);
c->backend_decl = field;
}
TYPE_FIELDS (typenode) = fieldlist;
gfc_finish_type (typenode);
derived->backend_decl = typenode;
return typenode;
}
int
gfc_return_by_reference (gfc_symbol * sym)
{
if (!sym->attr.function)
return 0;
if (sym->result)
sym = sym->result;
if (sym->attr.dimension)
return 1;
if (sym->ts.type == BT_CHARACTER)
return 1;
return 0;
}
tree
gfc_get_function_type (gfc_symbol * sym)
{
tree type;
tree typelist;
gfc_formal_arglist *f;
gfc_symbol *arg;
int nstr;
int alternate_return;
gcc_assert (sym->attr.flavor == FL_PROCEDURE);
if (sym->backend_decl)
return TREE_TYPE (sym->backend_decl);
nstr = 0;
alternate_return = 0;
typelist = NULL_TREE;
if (sym->attr.entry_master)
{
typelist = gfc_chainon_list (typelist, gfc_array_index_type);
}
if (gfc_return_by_reference (sym))
{
if (sym->result)
arg = sym->result;
else
arg = sym;
if (arg->ts.type == BT_CHARACTER)
gfc_conv_const_charlen (arg->ts.cl);
type = gfc_sym_type (arg);
if (arg->ts.type == BT_DERIVED
|| arg->attr.dimension
|| arg->ts.type == BT_CHARACTER)
type = build_reference_type (type);
typelist = gfc_chainon_list (typelist, type);
if (arg->ts.type == BT_CHARACTER)
typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
}
for (f = sym->formal; f; f = f->next)
{
arg = f->sym;
if (arg)
{
if (arg->ts.type == BT_CHARACTER)
gfc_conv_const_charlen (arg->ts.cl);
if (arg->attr.flavor == FL_PROCEDURE)
{
type = gfc_get_function_type (arg);
type = build_pointer_type (type);
}
else
type = gfc_sym_type (arg);
if (arg->ts.type == BT_CHARACTER)
nstr++;
typelist = gfc_chainon_list (typelist, type);
}
else
{
if (sym->attr.subroutine)
alternate_return = 1;
}
}
while (nstr--)
typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
typelist = gfc_chainon_list (typelist, void_type_node);
if (alternate_return)
type = integer_type_node;
else if (!sym->attr.function || gfc_return_by_reference (sym))
type = void_type_node;
else
type = gfc_sym_type (sym);
type = build_function_type (type, typelist);
return type;
}
tree
gfc_type_for_size (unsigned bits, int unsignedp)
{
if (!unsignedp)
{
int i;
for (i = 0; i <= MAX_INT_KINDS; ++i)
{
tree type = gfc_integer_types[i];
if (type && bits == TYPE_PRECISION (type))
return type;
}
}
else
{
if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
return unsigned_intQI_type_node;
if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
return unsigned_intHI_type_node;
if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
return unsigned_intSI_type_node;
if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
return unsigned_intDI_type_node;
if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
return unsigned_intTI_type_node;
}
return NULL_TREE;
}
tree
gfc_type_for_mode (enum machine_mode mode, int unsignedp)
{
int i;
tree *base;
if (GET_MODE_CLASS (mode) == MODE_FLOAT)
base = gfc_real_types;
else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
base = gfc_complex_types;
else if (SCALAR_INT_MODE_P (mode))
return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
else if (VECTOR_MODE_P (mode))
{
enum machine_mode inner_mode = GET_MODE_INNER (mode);
tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
if (inner_type != NULL_TREE)
return build_vector_type_for_mode (inner_type, mode);
return NULL_TREE;
}
else
return NULL_TREE;
for (i = 0; i <= MAX_REAL_KINDS; ++i)
{
tree type = base[i];
if (type && mode == TYPE_MODE (type))
return type;
}
return NULL_TREE;
}
tree
gfc_signed_or_unsigned_type (int unsignedp, tree type)
{
if (TREE_CODE (type) != INTEGER_TYPE || TYPE_UNSIGNED (type) == unsignedp)
return type;
else
return gfc_type_for_size (TYPE_PRECISION (type), unsignedp);
}
tree
gfc_unsigned_type (tree type)
{
return gfc_signed_or_unsigned_type (1, type);
}
tree
gfc_signed_type (tree type)
{
return gfc_signed_or_unsigned_type (0, type);
}
#include "gt-fortran-trans-types.h"