#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include <stdio.h>
#include "ggc.h"
#include "toplev.h"
#include <assert.h>
#include "gfortran.h"
#include "trans.h"
#include "trans-types.h"
#include "trans-const.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_type_nodes[NUM_F95_TYPES];
tree gfc_array_index_type;
tree pvoid_type_node;
tree ppvoid_type_node;
tree pchar_type_node;
static GTY(()) tree gfc_desc_dim_type = NULL;
static GTY(()) tree gfc_max_array_element_size;
void
gfc_init_types (void)
{
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))
gfc_int1_type_node = signed_char_type_node;
PUSH_TYPE ("int1", gfc_int1_type_node);
gfc_int2_type_node = short_integer_type_node;
PUSH_TYPE ("int2", gfc_int2_type_node);
gfc_int4_type_node = gfc_type_for_size (32, 0 );
PUSH_TYPE ("int4", gfc_int4_type_node);
gfc_int8_type_node = gfc_type_for_size (64, 0 );
PUSH_TYPE ("int8", gfc_int8_type_node);
#if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
gfc_int16_type_node = gfc_type_for_size (128, 0 );
PUSH_TYPE ("int16", gfc_int16_type_node);
#endif
gfc_real4_type_node = float_type_node;
PUSH_TYPE ("real4", gfc_real4_type_node);
gfc_real8_type_node = double_type_node;
PUSH_TYPE ("real8", gfc_real8_type_node);
#if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
gfc_real16_type_node = long_double_type_node;
PUSH_TYPE ("real16", gfc_real16_type_node);
#endif
gfc_complex4_type_node = complex_float_type_node;
PUSH_TYPE ("complex4", gfc_complex4_type_node);
gfc_complex8_type_node = complex_double_type_node;
PUSH_TYPE ("complex8", gfc_complex8_type_node);
#if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
gfc_complex16_type_node = complex_long_double_type_node;
PUSH_TYPE ("complex16", gfc_complex16_type_node);
#endif
gfc_logical1_type_node = make_node (BOOLEAN_TYPE);
TYPE_PRECISION (gfc_logical1_type_node) = 8;
fixup_unsigned_type (gfc_logical1_type_node);
PUSH_TYPE ("logical1", gfc_logical1_type_node);
gfc_logical2_type_node = make_node (BOOLEAN_TYPE);
TYPE_PRECISION (gfc_logical2_type_node) = 16;
fixup_unsigned_type (gfc_logical2_type_node);
PUSH_TYPE ("logical2", gfc_logical2_type_node);
gfc_logical4_type_node = make_node (BOOLEAN_TYPE);
TYPE_PRECISION (gfc_logical4_type_node) = 32;
fixup_unsigned_type (gfc_logical4_type_node);
PUSH_TYPE ("logical4", gfc_logical4_type_node);
gfc_logical8_type_node = make_node (BOOLEAN_TYPE);
TYPE_PRECISION (gfc_logical8_type_node) = 64;
fixup_unsigned_type (gfc_logical8_type_node);
PUSH_TYPE ("logical8", gfc_logical8_type_node);
#if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
gfc_logical16_type_node = make_node (BOOLEAN_TYPE);
TYPE_PRECISION (gfc_logical16_type_node) = 128;
fixup_unsigned_type (gfc_logical16_type_node);
PUSH_TYPE ("logical16", gfc_logical16_type_node);
#endif
gfc_character1_type_node = build_type_variant (signed_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_index_integer_kind = TYPE_PRECISION (long_unsigned_type_node) / 8;
gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
n = TREE_INT_CST_LOW (TYPE_SIZE (gfc_array_index_type))
- GFC_DTYPE_SIZE_SHIFT;
if (n > sizeof (HOST_WIDE_INT) * 8)
{
lo = ~(unsigned HOST_WIDE_INT) 0;
hi = lo >> (sizeof (HOST_WIDE_INT) * 16 - n);
}
else
{
hi = 0;
lo = (~(unsigned HOST_WIDE_INT) 0) >> (sizeof (HOST_WIDE_INT) * 8 - n);
}
gfc_max_array_element_size = build_int_2 (lo, hi);
TREE_TYPE (gfc_max_array_element_size) = long_unsigned_type_node;
size_type_node = gfc_array_index_type;
boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind ());
boolean_true_node = build_int_2 (1, 0);
TREE_TYPE (boolean_true_node) = boolean_type_node;
boolean_false_node = build_int_2 (0, 0);
TREE_TYPE (boolean_false_node) = boolean_type_node;
}
tree
gfc_get_int_type (int kind)
{
switch (kind)
{
case 1:
return (gfc_int1_type_node);
case 2:
return (gfc_int2_type_node);
case 4:
return (gfc_int4_type_node);
case 8:
return (gfc_int8_type_node);
#if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
case 16:
return (95 _int16_type_node);
#endif
default:
fatal_error ("integer kind=%d not available", kind);
}
}
tree
gfc_get_real_type (int kind)
{
switch (kind)
{
case 4:
return (gfc_real4_type_node);
case 8:
return (gfc_real8_type_node);
#if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
case 16:
return (gfc_real16_type_node);
#endif
default:
fatal_error ("real kind=%d not available", kind);
}
}
tree
gfc_get_complex_type (int kind)
{
switch (kind)
{
case 4:
return (gfc_complex4_type_node);
case 8:
return (gfc_complex8_type_node);
#if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
case 16:
return (gfc_complex16_type_node);
#endif
default:
fatal_error ("complex kind=%d not available", kind);
}
}
tree
gfc_get_logical_type (int kind)
{
switch (kind)
{
case 1:
return (gfc_logical1_type_node);
case 2:
return (gfc_logical2_type_node);
case 4:
return (gfc_logical4_type_node);
case 8:
return (gfc_logical8_type_node);
#if (GFC_USE_TYPES16 && (HOST_BITS_PER_WIDE_INT >= 64))
case 16:
return (gfc_logical16_type_node);
#endif
default:
fatal_error ("logical kind=%d not available", kind);
}
}
tree
gfc_get_character_type (int kind, gfc_charlen * cl)
{
tree base;
tree type;
tree len;
tree bounds;
switch (kind)
{
case 1:
base = gfc_character1_type_node;
break;
default:
fatal_error ("character kind=%d not available", kind);
}
len = (cl == 0) ? NULL_TREE : cl->backend_decl;
bounds = build_range_type (gfc_array_index_type, integer_one_node, len);
type = build_array_type (base, bounds);
TYPE_STRING_FLAG (type) = 1;
return type;
}
tree
gfc_typenode_for_spec (gfc_typespec * spec)
{
tree basetype;
switch (spec->type)
{
case BT_UNKNOWN:
abort ();
break;
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:
abort ();
break;
}
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);
assert (TREE_CODE (type) == ARRAY_TYPE);
element = TREE_TYPE (type);
}
else
{
assert (GFC_DESCRIPTOR_TYPE_P (type));
element = TREE_TYPE (TYPE_FIELDS (type));
assert (TREE_CODE (element) == POINTER_TYPE);
element = TREE_TYPE (element);
assert (TREE_CODE (element) == ARRAY_TYPE);
element = TREE_TYPE (element);
}
return element;
}
int
gfc_is_nodesc_array (gfc_symbol * sym)
{
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;
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] = integer_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;
}
static tree
gfc_get_dtype (tree type, int rank)
{
tree size;
int n;
HOST_WIDE_INT i;
tree tmp;
tree dtype;
if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
return (GFC_TYPE_ARRAY_DTYPE (type));
switch (TREE_CODE (type))
{
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:
abort ();
}
assert (rank <= GFC_DTYPE_RANK_MASK);
size = TYPE_SIZE_UNIT (type);
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_2 (i, 0);
TREE_TYPE (dtype) = gfc_array_index_type;
if (size && !INTEGER_CST_P (size))
{
tmp = build_int_2 (GFC_DTYPE_SIZE_SHIFT, 0);
TREE_TYPE (tmp) = gfc_array_index_type;
tmp = fold (build (LSHIFT_EXPR, gfc_array_index_type, size, tmp));
dtype = fold (build (PLUS_EXPR, gfc_array_index_type, tmp, 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_DTYPE (type) = gfc_get_dtype (etype, as->rank);
GFC_TYPE_ARRAY_RANK (type) = as->rank;
range = build_range_type (gfc_array_index_type, integer_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, integer_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) = gfc_get_dtype (etype, dimen);
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 = integer_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 (build (MINUS_EXPR, gfc_array_index_type, upper, lower));
tmp = fold (build (PLUS_EXPR, gfc_array_index_type, tmp,
integer_one_node));
stride =
fold (build (MULT_EXPR, gfc_array_index_type, tmp, stride));
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,
integer_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,
integer_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)
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, NULL, 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;
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 = make_node (RECORD_TYPE);
TYPE_NAME (field_type) = get_identifier (c->ts.derived->name);
TYPE_PACKED (field_type) = gfc_option.flag_pack_derived;
c->ts.derived->backend_decl = field_type;
}
}
else
{
if (c->ts.type == BT_CHARACTER)
{
gfc_conv_const_charlen (c->ts.cl);
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);
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;
assert (sym->attr.function);
if (sym->result)
sym = sym->result;
if (sym->attr.dimension)
return 1;
if (sym->ts.type == BT_CHARACTER)
return 1;
if (sym->ts.type == BT_DERIVED)
gfc_todo_error ("Returning derived types");
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;
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 (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_strlen_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_strlen_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 (bits == TYPE_PRECISION (integer_type_node))
return unsignedp ? unsigned_type_node : integer_type_node;
if (bits == TYPE_PRECISION (signed_char_type_node))
return unsignedp ? unsigned_char_type_node : signed_char_type_node;
if (bits == TYPE_PRECISION (short_integer_type_node))
return unsignedp ? short_unsigned_type_node : short_integer_type_node;
if (bits == TYPE_PRECISION (long_integer_type_node))
return unsignedp ? long_unsigned_type_node : long_integer_type_node;
if (bits == TYPE_PRECISION (long_long_integer_type_node))
return (unsignedp ? long_long_unsigned_type_node
: long_long_integer_type_node);
if (bits <= TYPE_PRECISION (intQI_type_node))
return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
if (bits <= TYPE_PRECISION (intHI_type_node))
return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
if (bits <= TYPE_PRECISION (intSI_type_node))
return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
if (bits <= TYPE_PRECISION (intDI_type_node))
return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
return 0;
}
tree
gfc_type_for_mode (enum machine_mode mode, int unsignedp)
{
if (mode == TYPE_MODE (integer_type_node))
return unsignedp ? unsigned_type_node : integer_type_node;
if (mode == TYPE_MODE (signed_char_type_node))
return unsignedp ? unsigned_char_type_node : signed_char_type_node;
if (mode == TYPE_MODE (short_integer_type_node))
return unsignedp ? short_unsigned_type_node : short_integer_type_node;
if (mode == TYPE_MODE (long_integer_type_node))
return unsignedp ? long_unsigned_type_node : long_integer_type_node;
if (mode == TYPE_MODE (long_long_integer_type_node))
return unsignedp ? long_long_unsigned_type_node :
long_long_integer_type_node;
if (mode == QImode)
return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
if (mode == HImode)
return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
if (mode == SImode)
return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
if (mode == DImode)
return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
#if HOST_BITS_PER_WIDE_INT >= 64
if (mode == TYPE_MODE (intTI_type_node))
return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
#endif
if (mode == TYPE_MODE (float_type_node))
return float_type_node;
if (mode == TYPE_MODE (double_type_node))
return double_type_node;
if (mode == TYPE_MODE (long_double_type_node))
return long_double_type_node;
if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
return build_pointer_type (char_type_node);
if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
return build_pointer_type (integer_type_node);
#ifdef VECTOR_MODE_SUPPORTED_P
if (VECTOR_MODE_SUPPORTED_P (mode))
{
switch (mode)
{
case V16QImode:
return unsignedp ? unsigned_V16QI_type_node : V16QI_type_node;
case V8HImode:
return unsignedp ? unsigned_V8HI_type_node : V8HI_type_node;
case V4SImode:
return unsignedp ? unsigned_V4SI_type_node : V4SI_type_node;
case V2DImode:
return unsignedp ? unsigned_V2DI_type_node : V2DI_type_node;
case V2SImode:
return unsignedp ? unsigned_V2SI_type_node : V2SI_type_node;
case V4HImode:
return unsignedp ? unsigned_V4HI_type_node : V4HI_type_node;
case V8QImode:
return unsignedp ? unsigned_V8QI_type_node : V8QI_type_node;
case V16SFmode:
return V16SF_type_node;
case V4SFmode:
return V4SF_type_node;
case V2SFmode:
return V2SF_type_node;
case V2DFmode:
return V2DF_type_node;
default:
break;
}
}
#endif
return 0;
}
tree
gfc_unsigned_type (tree type)
{
tree type1 = TYPE_MAIN_VARIANT (type);
if (type1 == signed_char_type_node || type1 == char_type_node)
return unsigned_char_type_node;
if (type1 == integer_type_node)
return unsigned_type_node;
if (type1 == short_integer_type_node)
return short_unsigned_type_node;
if (type1 == long_integer_type_node)
return long_unsigned_type_node;
if (type1 == long_long_integer_type_node)
return long_long_unsigned_type_node;
#if HOST_BITS_PER_WIDE_INT >= 64
if (type1 == intTI_type_node)
return unsigned_intTI_type_node;
#endif
if (type1 == intDI_type_node)
return unsigned_intDI_type_node;
if (type1 == intSI_type_node)
return unsigned_intSI_type_node;
if (type1 == intHI_type_node)
return unsigned_intHI_type_node;
if (type1 == intQI_type_node)
return unsigned_intQI_type_node;
return gfc_signed_or_unsigned_type (1, type);
}
tree
gfc_signed_type (tree type)
{
tree type1 = TYPE_MAIN_VARIANT (type);
if (type1 == unsigned_char_type_node || type1 == char_type_node)
return signed_char_type_node;
if (type1 == unsigned_type_node)
return integer_type_node;
if (type1 == short_unsigned_type_node)
return short_integer_type_node;
if (type1 == long_unsigned_type_node)
return long_integer_type_node;
if (type1 == long_long_unsigned_type_node)
return long_long_integer_type_node;
#if HOST_BITS_PER_WIDE_INT >= 64
if (type1 == unsigned_intTI_type_node)
return intTI_type_node;
#endif
if (type1 == unsigned_intDI_type_node)
return intDI_type_node;
if (type1 == unsigned_intSI_type_node)
return intSI_type_node;
if (type1 == unsigned_intHI_type_node)
return intHI_type_node;
if (type1 == unsigned_intQI_type_node)
return intQI_type_node;
return gfc_signed_or_unsigned_type (0, type);
}
tree
gfc_signed_or_unsigned_type (int unsignedp, tree type)
{
if (!INTEGRAL_TYPE_P (type) || TYPE_UNSIGNED (type) == unsignedp)
return type;
if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
return unsignedp ? unsigned_char_type_node : signed_char_type_node;
if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
return unsignedp ? unsigned_type_node : integer_type_node;
if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
return unsignedp ? short_unsigned_type_node : short_integer_type_node;
if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
return unsignedp ? long_unsigned_type_node : long_integer_type_node;
if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
return (unsignedp ? long_long_unsigned_type_node
: long_long_integer_type_node);
#if HOST_BITS_PER_WIDE_INT >= 64
if (TYPE_PRECISION (type) == TYPE_PRECISION (intTI_type_node))
return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
#endif
if (TYPE_PRECISION (type) == TYPE_PRECISION (intDI_type_node))
return unsignedp ? unsigned_intDI_type_node : intDI_type_node;
if (TYPE_PRECISION (type) == TYPE_PRECISION (intSI_type_node))
return unsignedp ? unsigned_intSI_type_node : intSI_type_node;
if (TYPE_PRECISION (type) == TYPE_PRECISION (intHI_type_node))
return unsignedp ? unsigned_intHI_type_node : intHI_type_node;
if (TYPE_PRECISION (type) == TYPE_PRECISION (intQI_type_node))
return unsignedp ? unsigned_intQI_type_node : intQI_type_node;
return type;
}
#include "gt-fortran-trans-types.h"