/* Backend support for Fortran 95 basic types and derived types.
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
- Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+ 2010
+ Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#include "trans-const.h"
#include "real.h"
#include "flags.h"
+#include "dwarf2out.h"
\f
#if (GFC_MAX_DIMENSIONS < 10)
/* array of structs so we don't have to worry about xmalloc or free */
CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER];
-static tree gfc_get_derived_type (gfc_symbol * derived);
-
tree gfc_array_index_type;
tree gfc_array_range_type;
tree gfc_character1_type_node;
tree pvoid_type_node;
+tree prvoid_type_node;
tree ppvoid_type_node;
tree pchar_type_node;
tree pfunc_type_node;
static GTY(()) tree gfc_desc_dim_type;
static GTY(()) tree gfc_max_array_element_size;
-static GTY(()) tree gfc_array_descriptor_base[GFC_MAX_DIMENSIONS];
+static GTY(()) tree gfc_array_descriptor_base[2 * GFC_MAX_DIMENSIONS];
/* Arrays for all integral and real kinds. We'll fill this in at runtime
after the target has a chance to process command-line options. */
static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];
static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];
+#define MAX_CHARACTER_KINDS 2
+gfc_character_info gfc_character_kinds[MAX_CHARACTER_KINDS + 1];
+static GTY(()) tree gfc_character_types[MAX_CHARACTER_KINDS + 1];
+static GTY(()) tree gfc_pcharacter_types[MAX_CHARACTER_KINDS + 1];
+
/* The integer kind to use for array indices. This will be set to the
proper value based on target information from the backend. */
int gfc_character_storage_size;
-/* Validate that the f90_type of the given gfc_typespec is valid for
- the type it represents. The f90_type represents the Fortran types
- this C kind can be used with. For example, c_int has a f90_type of
- BT_INTEGER and c_float has a f90_type of BT_REAL. Returns FAILURE
- if a mismatch occurs between ts->f90_type and ts->type; SUCCESS if
- they match. */
-
-try
-gfc_validate_c_kind (gfc_typespec *ts)
-{
- return ((ts->type == ts->f90_type) ? SUCCESS : FAILURE);
-}
-
-
-try
+gfc_try
gfc_check_any_c_kind (gfc_typespec *ts)
{
int i;
return -1;
}
+/* Return a typenode for the "standard" C type with a given name. */
+static tree
+get_typenode_from_name (const char *name)
+{
+ if (name == NULL || *name == '\0')
+ return NULL_TREE;
+
+ if (strcmp (name, "char") == 0)
+ return char_type_node;
+ if (strcmp (name, "unsigned char") == 0)
+ return unsigned_char_type_node;
+ if (strcmp (name, "signed char") == 0)
+ return signed_char_type_node;
+
+ if (strcmp (name, "short int") == 0)
+ return short_integer_type_node;
+ if (strcmp (name, "short unsigned int") == 0)
+ return short_unsigned_type_node;
+
+ if (strcmp (name, "int") == 0)
+ return integer_type_node;
+ if (strcmp (name, "unsigned int") == 0)
+ return unsigned_type_node;
+
+ if (strcmp (name, "long int") == 0)
+ return long_integer_type_node;
+ if (strcmp (name, "long unsigned int") == 0)
+ return long_unsigned_type_node;
+
+ if (strcmp (name, "long long int") == 0)
+ return long_long_integer_type_node;
+ if (strcmp (name, "long long unsigned int") == 0)
+ return long_long_unsigned_type_node;
+
+ gcc_unreachable ();
+}
+
+static int
+get_int_kind_from_name (const char *name)
+{
+ return get_int_kind_from_node (get_typenode_from_name (name));
+}
+
+
+/* Get the kind number corresponding to an integer of given size,
+ following the required return values for ISO_FORTRAN_ENV INT* constants:
+ -2 is returned if we support a kind of larger size, -1 otherwise. */
+int
+gfc_get_int_kind_from_width_isofortranenv (int size)
+{
+ int i;
+
+ /* Look for a kind with matching storage size. */
+ for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+ if (gfc_integer_kinds[i].bit_size == size)
+ return gfc_integer_kinds[i].kind;
+
+ /* Look for a kind with larger storage size. */
+ for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+ if (gfc_integer_kinds[i].bit_size > size)
+ return -2;
+
+ return -1;
+}
+
+/* Get the kind number corresponding to a real of given storage size,
+ following the required return values for ISO_FORTRAN_ENV REAL* constants:
+ -2 is returned if we support a kind of larger size, -1 otherwise. */
+int
+gfc_get_real_kind_from_width_isofortranenv (int size)
+{
+ int i;
+
+ size /= 8;
+
+ /* Look for a kind with matching storage size. */
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size)
+ return gfc_real_kinds[i].kind;
+
+ /* Look for a kind with larger storage size. */
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size)
+ return -2;
+
+ return -1;
+}
+
+
+
static int
get_int_kind_from_width (int size)
{
void init_c_interop_kinds (void)
{
int i;
- tree intmax_type_node = INT_TYPE_SIZE == LONG_LONG_TYPE_SIZE ?
- integer_type_node :
- (LONG_TYPE_SIZE == LONG_LONG_TYPE_SIZE ?
- long_integer_type_node :
- long_long_integer_type_node);
/* init all pointers in the list to NULL */
for (i = 0; i < ISOCBINDING_NUMBER; i++)
c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
}
-#define NAMED_INTCST(a,b,c) \
+#define NAMED_INTCST(a,b,c,d) \
strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
c_interop_kinds_table[a].f90_type = BT_INTEGER; \
c_interop_kinds_table[a].value = c;
void
gfc_init_kinds (void)
{
- enum machine_mode mode;
- int i_index, r_index;
+ unsigned int mode;
+ int i_index, r_index, kind;
bool saw_i4 = false, saw_i8 = false;
bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
{
int kind, bitsize;
- if (!targetm.scalar_mode_supported_p (mode))
+ if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
continue;
/* The middle end doesn't support constants larger than 2*HWI.
for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
{
- const struct real_format *fmt = REAL_MODE_FORMAT (mode);
+ const struct real_format *fmt =
+ REAL_MODE_FORMAT ((enum machine_mode) mode);
int kind;
if (fmt == NULL)
continue;
- if (!targetm.scalar_mode_supported_p (mode))
+ if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
continue;
/* Only let float/double/long double go through because the fortran
if (kind == 16)
saw_r16 = true;
- /* Careful we don't stumble a wierd internal mode. */
+ /* Careful we don't stumble a weird internal mode. */
gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
/* Or have too many modes for the allocated space. */
gcc_assert (r_index != MAX_REAL_KINDS);
gfc_default_integer_kind = 8;
/* Even if the user specified that the default integer kind be 8,
- the numerica storage size isn't 64. In this case, a warning will
+ the numeric storage size isn't 64. In this case, a warning will
be issued when NUMERIC_STORAGE_SIZE is used. */
gfc_numeric_storage_size = 4 * 8;
}
gfc_default_logical_kind = gfc_default_integer_kind;
gfc_default_complex_kind = gfc_default_real_kind;
+ /* We only have two character kinds: ASCII and UCS-4.
+ ASCII corresponds to a 8-bit integer type, if one is available.
+ UCS-4 corresponds to a 32-bit integer type, if one is available. */
+ i_index = 0;
+ if ((kind = get_int_kind_from_width (8)) > 0)
+ {
+ gfc_character_kinds[i_index].kind = kind;
+ gfc_character_kinds[i_index].bit_size = 8;
+ gfc_character_kinds[i_index].name = "ascii";
+ i_index++;
+ }
+ if ((kind = get_int_kind_from_width (32)) > 0)
+ {
+ gfc_character_kinds[i_index].kind = kind;
+ gfc_character_kinds[i_index].bit_size = 32;
+ gfc_character_kinds[i_index].name = "iso_10646";
+ i_index++;
+ }
+
/* Choose the smallest integer kind for our default character. */
- gfc_default_character_kind = gfc_integer_kinds[0].kind;
+ gfc_default_character_kind = gfc_character_kinds[0].kind;
gfc_character_storage_size = gfc_default_character_kind * 8;
/* Choose the integer kind the same size as "void*" for our index kind. */
static int
validate_character (int kind)
{
- return kind == gfc_default_character_kind ? 0 : -1;
+ int i;
+
+ for (i = 0; gfc_character_kinds[i].kind; i++)
+ if (gfc_character_kinds[i].kind == kind)
+ return i;
+
+ return -1;
}
/* Validate a kind given a basic type. The return value is the same
return make_signed_type (mode_precision);
}
+tree
+gfc_build_uint_type (int size)
+{
+ if (size == CHAR_TYPE_SIZE)
+ return unsigned_char_type_node;
+ if (size == SHORT_TYPE_SIZE)
+ return short_unsigned_type_node;
+ if (size == INT_TYPE_SIZE)
+ return unsigned_type_node;
+ if (size == LONG_TYPE_SIZE)
+ return long_unsigned_type_node;
+ if (size == LONG_LONG_TYPE_SIZE)
+ return long_long_unsigned_type_node;
+
+ return make_unsigned_type (size);
+}
+
+
static tree
gfc_build_real_type (gfc_real_info *info)
{
return new_type;
}
+
#if 0
/* Return the bit size of the C "size_t". */
void
gfc_init_types (void)
{
- char name_buf[16];
+ char name_buf[18];
int index;
tree type;
unsigned n;
/* Create and name the types. */
#define PUSH_TYPE(name, node) \
- pushdecl (build_decl (TYPE_DECL, get_identifier (name), node))
+ pushdecl (build_decl (input_location, \
+ 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]);
+ /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */
+ if (TYPE_STRING_FLAG (type))
+ type = make_signed_type (gfc_integer_kinds[index].bit_size);
gfc_integer_types[index] = type;
- snprintf (name_buf, sizeof(name_buf), "int%d",
+ snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)",
gfc_integer_kinds[index].kind);
PUSH_TYPE (name_buf, type);
}
{
type = gfc_build_logical_type (&gfc_logical_kinds[index]);
gfc_logical_types[index] = type;
- snprintf (name_buf, sizeof(name_buf), "logical%d",
+ snprintf (name_buf, sizeof(name_buf), "logical(kind=%d)",
gfc_logical_kinds[index].kind);
PUSH_TYPE (name_buf, type);
}
{
type = gfc_build_real_type (&gfc_real_kinds[index]);
gfc_real_types[index] = type;
- snprintf (name_buf, sizeof(name_buf), "real%d",
+ snprintf (name_buf, sizeof(name_buf), "real(kind=%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",
+ snprintf (name_buf, sizeof(name_buf), "complex(kind=%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);
+ for (index = 0; gfc_character_kinds[index].kind != 0; ++index)
+ {
+ type = gfc_build_uint_type (gfc_character_kinds[index].bit_size);
+ type = build_qualified_type (type, TYPE_UNQUALIFIED);
+ snprintf (name_buf, sizeof(name_buf), "character(kind=%d)",
+ gfc_character_kinds[index].kind);
+ PUSH_TYPE (name_buf, type);
+ gfc_character_types[index] = type;
+ gfc_pcharacter_types[index] = build_pointer_type (type);
+ }
+ gfc_character1_type_node = gfc_character_types[0];
PUSH_TYPE ("byte", unsigned_char_type_node);
PUSH_TYPE ("void", void_type_node);
#undef PUSH_TYPE
pvoid_type_node = build_pointer_type (void_type_node);
+ prvoid_type_node = build_qualified_type (pvoid_type_node, TYPE_QUAL_RESTRICT);
ppvoid_type_node = build_pointer_type (pvoid_type_node);
pchar_type_node = build_pointer_type (gfc_character1_type_node);
pfunc_type_node
int index = gfc_validate_kind (BT_LOGICAL, kind, true);
return index < 0 ? 0 : gfc_logical_types[index];
}
+
+tree
+gfc_get_char_type (int kind)
+{
+ int index = gfc_validate_kind (BT_CHARACTER, kind, true);
+ return index < 0 ? 0 : gfc_character_types[index];
+}
+
+tree
+gfc_get_pchar_type (int kind)
+{
+ int index = gfc_validate_kind (BT_CHARACTER, kind, true);
+ return index < 0 ? 0 : gfc_pcharacter_types[index];
+}
+
\f
/* Create a character type with the given kind and length. */
tree
-gfc_get_character_type_len (int kind, tree len)
+gfc_get_character_type_len_for_eltype (tree eltype, 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 = build_array_type (eltype, bounds);
TYPE_STRING_FLAG (type) = 1;
return type;
}
+tree
+gfc_get_character_type_len (int kind, tree len)
+{
+ gfc_validate_kind (BT_CHARACTER, kind, false);
+ return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len);
+}
+
/* Get a type node for a character kind. */
C_FUNPTR to simple variables that get translated to (void *). */
if (spec->f90_type == BT_VOID)
{
- if (spec->derived
- && spec->derived->intmod_sym_id == ISOCBINDING_PTR)
+ if (spec->u.derived
+ && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
basetype = ptr_type_node;
else
basetype = pfunc_type_node;
break;
case BT_CHARACTER:
- basetype = gfc_get_character_type (spec->kind, spec->cl);
+ basetype = gfc_get_character_type (spec->kind, spec->u.cl);
break;
case BT_DERIVED:
- basetype = gfc_get_derived_type (spec->derived);
+ case BT_CLASS:
+ basetype = gfc_get_derived_type (spec->u.derived);
/* If we're dealing with either C_PTR or C_FUNPTR, we modified the
type and kind to fit a (void *) and the basetype returned was a
ptr_type_node. We need to pass up this new information to the
symbol that was declared of type C_PTR or C_FUNPTR. */
- if (spec->derived->attr.is_iso_c)
+ if (spec->u.derived->attr.is_iso_c)
{
- spec->type = spec->derived->ts.type;
- spec->kind = spec->derived->ts.kind;
- spec->f90_type = spec->derived->ts.f90_type;
+ spec->type = spec->u.derived->ts.type;
+ spec->kind = spec->u.derived->ts.kind;
+ spec->f90_type = spec->u.derived->ts.f90_type;
}
break;
case BT_VOID:
basetype = ptr_type_node;
if (spec->f90_type == BT_VOID)
{
- if (spec->derived
- && spec->derived->intmod_sym_id == ISOCBINDING_PTR)
+ if (spec->u.derived
+ && spec->u.derived->intmod_sym_id == ISOCBINDING_PTR)
basetype = ptr_type_node;
else
basetype = pfunc_type_node;
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.
+ offset field is the position of the origin of the array (i.e. element
+ (0, 0 ...)). This may be outside the bounds of the array.
An element is accessed by
data[offset + index0*stride0 + index1*stride1 + index2*stride2]
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
+ 2^31, so the calculation for stride2 would overflow. This may
still work, but I haven't checked, and it relies on the overflow
doing the right thing.
if (sym->attr.result || sym->attr.function)
return 0;
- gcc_assert (sym->as->type == AS_EXPLICIT);
+ gcc_assert (sym->as->type == AS_EXPLICIT || sym->as->cp_was_assumed);
return 1;
}
/* Create an array descriptor type. */
static tree
-gfc_build_array_type (tree type, gfc_array_spec * as)
+gfc_build_array_type (tree type, gfc_array_spec * as,
+ enum gfc_array_kind akind, bool restricted)
{
tree lbound[GFC_MAX_DIMENSIONS];
tree ubound[GFC_MAX_DIMENSIONS];
ubound[n] = gfc_conv_array_bound (as->upper[n]);
}
- return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
+ if (as->type == AS_ASSUMED_SHAPE)
+ akind = GFC_ARRAY_ASSUMED_SHAPE;
+ return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound,
+ ubound, 0, akind, restricted);
}
\f
/* Returns the struct descriptor_dimension type. */
TYPE_PACKED (type) = 1;
/* Consists of the stride, lbound and ubound members. */
- decl = build_decl (FIELD_DECL,
+ decl = build_decl (input_location,
+ FIELD_DECL,
get_identifier ("stride"), gfc_array_index_type);
DECL_CONTEXT (decl) = type;
+ TREE_NO_WARNING (decl) = 1;
fieldlist = decl;
- decl = build_decl (FIELD_DECL,
+ decl = build_decl (input_location,
+ FIELD_DECL,
get_identifier ("lbound"), gfc_array_index_type);
DECL_CONTEXT (decl) = type;
+ TREE_NO_WARNING (decl) = 1;
fieldlist = chainon (fieldlist, decl);
- decl = build_decl (FIELD_DECL,
+ decl = build_decl (input_location,
+ FIELD_DECL,
get_identifier ("ubound"), gfc_array_index_type);
DECL_CONTEXT (decl) = type;
+ TREE_NO_WARNING (decl) = 1;
fieldlist = chainon (fieldlist, decl);
/* Finish off the type. */
to the value of PACKED. */
tree
-gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
+gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
+ bool restricted)
{
tree range;
tree type;
if (expr->expr_type == EXPR_CONSTANT)
{
tmp = gfc_conv_mpz_to_tree (expr->value.integer,
- gfc_index_integer_kind);
+ gfc_index_integer_kind);
}
else
{
/* TODO: use main type if it is unbounded. */
GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
build_pointer_type (build_array_type (etype, range));
+ if (restricted)
+ GFC_TYPE_ARRAY_DATAPTR_TYPE (type) =
+ build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type),
+ TYPE_QUAL_RESTRICT);
if (known_stride)
{
mpz_clear (stride);
mpz_clear (delta);
- /* In debug info represent packed arrays as multi-dimensional
- if they have rank > 1 and with proper bounds, instead of flat
- arrays. */
- if (known_stride && write_symbols != NO_DEBUG)
+ /* Represent packed arrays as multi-dimensional if they have rank >
+ 1 and with proper bounds, instead of flat arrays. This makes for
+ better debug info. */
+ if (known_offset)
{
tree gtype = etype, rtype, type_decl;
GFC_TYPE_ARRAY_UBOUND (type, n));
gtype = build_array_type (gtype, rtype);
}
- TYPE_NAME (type) = type_decl = build_decl (TYPE_DECL, NULL, gtype);
+ TYPE_NAME (type) = type_decl = build_decl (input_location,
+ TYPE_DECL, NULL, gtype);
DECL_ORIGINAL_TYPE (type_decl) = gtype;
}
/* For dummy arrays and automatic (heap allocated) arrays we
want a pointer to the array. */
type = build_pointer_type (type);
+ if (restricted)
+ type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
GFC_ARRAY_TYPE_P (type) = 1;
TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
}
/* Return or create the base type for an array descriptor. */
static tree
-gfc_get_array_descriptor_base (int dimen)
+gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
{
tree fat_type, fieldlist, decl, arraytype;
- char name[16 + GFC_RANK_DIGITS + 1];
+ char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
+ int idx = 2 * (codimen + dimen - 1) + restricted;
- gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
- if (gfc_array_descriptor_base[dimen - 1])
- return gfc_array_descriptor_base[dimen - 1];
+ gcc_assert (dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS);
+ if (gfc_array_descriptor_base[idx])
+ return gfc_array_descriptor_base[idx];
/* Build the type node. */
fat_type = make_node (RECORD_TYPE);
- sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen);
+ sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen + codimen);
TYPE_NAME (fat_type) = get_identifier (name);
/* Add the data member as the first element of the descriptor. */
- decl = build_decl (FIELD_DECL, get_identifier ("data"), ptr_type_node);
+ decl = build_decl (input_location,
+ FIELD_DECL, get_identifier ("data"),
+ restricted ? prvoid_type_node : ptr_type_node);
DECL_CONTEXT (decl) = fat_type;
fieldlist = decl;
/* Add the base component. */
- decl = build_decl (FIELD_DECL, get_identifier ("offset"),
+ decl = build_decl (input_location,
+ FIELD_DECL, get_identifier ("offset"),
gfc_array_index_type);
DECL_CONTEXT (decl) = fat_type;
+ TREE_NO_WARNING (decl) = 1;
fieldlist = chainon (fieldlist, decl);
/* Add the dtype component. */
- decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
+ decl = build_decl (input_location,
+ FIELD_DECL, get_identifier ("dtype"),
gfc_array_index_type);
DECL_CONTEXT (decl) = fat_type;
+ TREE_NO_WARNING (decl) = 1;
fieldlist = chainon (fieldlist, decl);
/* Build the array type for the stride and bound components. */
build_array_type (gfc_get_desc_dim_type (),
build_range_type (gfc_array_index_type,
gfc_index_zero_node,
- gfc_rank_cst[dimen - 1]));
+ gfc_rank_cst[codimen + dimen - 1]));
- decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
+ decl = build_decl (input_location,
+ FIELD_DECL, get_identifier ("dim"), arraytype);
DECL_CONTEXT (decl) = fat_type;
+ TREE_NO_WARNING (decl) = 1;
fieldlist = chainon (fieldlist, decl);
/* Finish off the type. */
gfc_finish_type (fat_type);
TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
- gfc_array_descriptor_base[dimen - 1] = fat_type;
+ gfc_array_descriptor_base[idx] = fat_type;
return fat_type;
}
/* Build an array (descriptor) type with given bounds. */
tree
-gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
- tree * ubound, int packed)
+gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
+ tree * ubound, int packed,
+ enum gfc_array_kind akind, bool restricted)
{
- char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
- tree fat_type, base_type, arraytype, lower, upper, stride, tmp;
- const char *typename;
+ char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN];
+ tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
+ const char *type_name;
int n;
- base_type = gfc_get_array_descriptor_base (dimen);
- fat_type = build_variant_type_copy (base_type);
+ base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted);
+ fat_type = build_distinct_type_copy (base_type);
+ /* Make sure that nontarget and target array type have the same canonical
+ type (and same stub decl for debug info). */
+ base_type = gfc_get_array_descriptor_base (dimen, codimen, false);
+ TYPE_CANONICAL (fat_type) = base_type;
+ TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
tmp = TYPE_NAME (etype);
if (tmp && TREE_CODE (tmp) == TYPE_DECL)
tmp = DECL_NAME (tmp);
if (tmp)
- typename = IDENTIFIER_POINTER (tmp);
+ type_name = IDENTIFIER_POINTER (tmp);
else
- typename = "unknown";
- sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
- GFC_MAX_SYMBOL_LEN, typename);
+ type_name = "unknown";
+ sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen + codimen,
+ GFC_MAX_SYMBOL_LEN, type_name);
TYPE_NAME (fat_type) = get_identifier (name);
GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
+ GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
/* Build an array descriptor record type. */
if (packed != 0)
/* TODO: known offsets for descriptors. */
GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
- /* We define data as an unknown size array. Much better than doing
- pointer arithmetic. */
- arraytype =
- build_array_type (etype, gfc_array_range_type);
+ /* We define data as an array with the correct size if possible.
+ Much better than doing pointer arithmetic. */
+ if (stride)
+ rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+ int_const_binop (MINUS_EXPR, stride,
+ integer_one_node, 0));
+ else
+ rtype = gfc_array_range_type;
+ arraytype = build_array_type (etype, rtype);
arraytype = build_pointer_type (arraytype);
+ if (restricted)
+ arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
+ /* This will generate the base declarations we need to emit debug
+ information for this type. FIXME: there must be a better way to
+ avoid divergence between compilations with and without debug
+ information. */
+ {
+ struct array_descr_info info;
+ gfc_get_array_descr_info (fat_type, &info);
+ gfc_get_array_descr_info (build_pointer_type (fat_type), &info);
+ }
+
return fat_type;
}
\f
{
tree type;
int byref;
+ bool restricted;
+
+ /* Procedure Pointers inside COMMON blocks. */
+ if (sym->attr.proc_pointer && sym->attr.in_common)
+ {
+ /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
+ sym->attr.proc_pointer = 0;
+ type = build_pointer_type (gfc_get_function_type (sym));
+ sym->attr.proc_pointer = 1;
+ return type;
+ }
if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
return void_type_node;
if (sym->backend_decl && !sym->attr.function)
return TREE_TYPE (sym->backend_decl);
- type = gfc_typenode_for_spec (&sym->ts);
+ if (sym->ts.type == BT_CHARACTER
+ && ((sym->attr.function && sym->attr.is_bind_c)
+ || (sym->attr.result
+ && sym->ns->proc_name
+ && sym->ns->proc_name->attr.is_bind_c)))
+ type = gfc_character1_type_node;
+ else
+ type = gfc_typenode_for_spec (&sym->ts);
if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
byref = 1;
else
byref = 0;
+ restricted = !sym->attr.target && !sym->attr.pointer
+ && !sym->attr.proc_pointer && !sym->attr.cray_pointee;
if (sym->attr.dimension)
{
if (gfc_is_nodesc_array (sym))
base type. */
if (sym->ts.type != BT_CHARACTER
|| !(sym->attr.dummy || sym->attr.function)
- || sym->ts.cl->backend_decl)
+ || sym->ts.u.cl->backend_decl)
{
type = gfc_get_nodesc_array_type (type, sym->as,
byref ? PACKED_FULL
- : PACKED_STATIC);
+ : PACKED_STATIC,
+ restricted);
byref = 0;
}
+
+ if (sym->attr.cray_pointee)
+ GFC_POINTER_TYPE_P (type) = 1;
}
else
- {
- type = gfc_build_array_type (type, sym->as);
- }
+ {
+ enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
+ if (sym->attr.pointer)
+ akind = GFC_ARRAY_POINTER;
+ else if (sym->attr.allocatable)
+ akind = GFC_ARRAY_ALLOCATABLE;
+ type = gfc_build_array_type (type, sym->as, akind, restricted);
+ }
}
else
{
if (sym->attr.allocatable || sym->attr.pointer)
type = gfc_build_pointer_type (sym, type);
- if (sym->attr.pointer)
+ if (sym->attr.pointer || sym->attr.cray_pointee)
GFC_POINTER_TYPE_P (type) = 1;
}
if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
type = build_pointer_type (type);
else
- type = build_reference_type (type);
+ {
+ type = build_reference_type (type);
+ if (restricted)
+ type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
+ }
}
return (type);
{
tree decl;
- decl = build_decl (TYPE_DECL, NULL_TREE, type);
+ decl = build_decl (input_location,
+ TYPE_DECL, NULL_TREE, type);
TYPE_STUB_DECL (type) = decl;
layout_type (type);
rest_of_type_compilation (type, 1);
{
tree decl;
- decl = build_decl (FIELD_DECL, name, type);
+ decl = build_decl (input_location,
+ FIELD_DECL, name, type);
DECL_CONTEXT (decl) = context;
DECL_INITIAL (decl) = 0;
in 4.4.2 and resolved by gfc_compare_derived_types. */
static int
-copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
+copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
+ bool from_gsym)
{
gfc_component *to_cm;
gfc_component *from_cm;
for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
{
to_cm->backend_decl = from_cm->backend_decl;
- if (!from_cm->pointer && from_cm->ts.type == BT_DERIVED)
- gfc_get_derived_type (to_cm->ts.derived);
+ if ((!from_cm->attr.pointer || from_gsym)
+ && from_cm->ts.type == BT_DERIVED)
+ gfc_get_derived_type (to_cm->ts.u.derived);
else if (from_cm->ts.type == BT_CHARACTER)
- to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl;
+ to_cm->ts.u.cl->backend_decl = from_cm->ts.u.cl->backend_decl;
}
return 1;
}
+/* Build a tree node for a procedure pointer component. */
+
+tree
+gfc_get_ppc_type (gfc_component* c)
+{
+ tree t;
+
+ /* Explicit interface. */
+ if (c->attr.if_source != IFSRC_UNKNOWN && c->ts.interface)
+ return build_pointer_type (gfc_get_function_type (c->ts.interface));
+
+ /* Implicit interface (only return value may be known). */
+ if (c->attr.function && !c->attr.dimension && c->ts.type != BT_CHARACTER)
+ t = gfc_typenode_for_spec (&c->ts);
+ else
+ t = void_type_node;
+
+ return build_pointer_type (build_function_type (t, NULL_TREE));
+}
+
+
/* Build a tree node for a derived type. If there are equal
derived types, with different local names, these are built
at the same time. If an equal derived type has been built
in a parent namespace, this is used. */
-static tree
+tree
gfc_get_derived_type (gfc_symbol * derived)
{
tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
+ tree canonical = NULL_TREE;
+ bool got_canonical = false;
gfc_component *c;
gfc_dt_list *dt;
+ gfc_namespace *ns;
+ gfc_gsymbol *gsym;
gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
return derived->backend_decl;
}
-
+
+/* If use associated, use the module type for this one. */
+ if (gfc_option.flag_whole_file
+ && derived->backend_decl == NULL
+ && derived->attr.use_assoc
+ && derived->module)
+ {
+ gsym = gfc_find_gsymbol (gfc_gsym_root, derived->module);
+ if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
+ {
+ gfc_symbol *s;
+ s = NULL;
+ gfc_find_symbol (derived->name, gsym->ns, 0, &s);
+ if (s && s->backend_decl)
+ {
+ copy_dt_decls_ifequal (s, derived, true);
+ goto copy_derived_types;
+ }
+ }
+ }
+
+ /* If a whole file compilation, the derived types from an earlier
+ namespace can be used as the the canonical type. */
+ if (gfc_option.flag_whole_file
+ && derived->backend_decl == NULL
+ && !derived->attr.use_assoc
+ && gfc_global_ns_list)
+ {
+ for (ns = gfc_global_ns_list;
+ ns->translated && !got_canonical;
+ ns = ns->sibling)
+ {
+ dt = ns->derived_types;
+ for (; dt && !canonical; dt = dt->next)
+ {
+ copy_dt_decls_ifequal (dt->derived, derived, true);
+ if (derived->backend_decl)
+ got_canonical = true;
+ }
+ }
+ }
+
+ /* Store up the canonical type to be added to this one. */
+ if (got_canonical)
+ {
+ if (TYPE_CANONICAL (derived->backend_decl))
+ canonical = TYPE_CANONICAL (derived->backend_decl);
+ else
+ canonical = derived->backend_decl;
+
+ derived->backend_decl = NULL_TREE;
+ }
+
/* derived->backend_decl != 0 means we saw it before, but its
components' backend_decl may have not been built. */
if (derived->backend_decl)
{
- /* Its components' backend_decl have been built. */
- if (TYPE_FIELDS (derived->backend_decl))
+ /* Its components' backend_decl have been built or we are
+ seeing recursion through the formal arglist of a procedure
+ pointer component. */
+ if (TYPE_FIELDS (derived->backend_decl)
+ || derived->attr.proc_pointer_comp)
return derived->backend_decl;
else
typenode = derived->backend_decl;
}
else
{
-
/* We see this derived type first time, so build the type node. */
typenode = make_node (RECORD_TYPE);
TYPE_NAME (typenode) = get_identifier (derived->name);
will be built and so we can return the type. */
for (c = derived->components; c; c = c->next)
{
- if (c->ts.type != BT_DERIVED)
+ if (c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS)
continue;
- if (!c->pointer || c->ts.derived->backend_decl == NULL)
- c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
+ if ((!c->attr.pointer && !c->attr.proc_pointer)
+ || c->ts.u.derived->backend_decl == NULL)
+ c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived);
- if (c->ts.derived && c->ts.derived->attr.is_iso_c)
+ if (c->ts.u.derived && c->ts.u.derived->attr.is_iso_c)
{
/* Need to copy the modified ts from the derived type. The
typespec was modified because C_PTR/C_FUNPTR are translated
into (void *) from derived types. */
- c->ts.type = c->ts.derived->ts.type;
- c->ts.kind = c->ts.derived->ts.kind;
- c->ts.f90_type = c->ts.derived->ts.f90_type;
+ c->ts.type = c->ts.u.derived->ts.type;
+ c->ts.kind = c->ts.u.derived->ts.kind;
+ c->ts.f90_type = c->ts.u.derived->ts.f90_type;
if (c->initializer)
{
c->initializer->ts.type = c->ts.type;
fieldlist = NULL_TREE;
for (c = derived->components; c; c = c->next)
{
- if (c->ts.type == BT_DERIVED)
- field_type = c->ts.derived->backend_decl;
+ if (c->attr.proc_pointer)
+ field_type = gfc_get_ppc_type (c);
+ else if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
+ field_type = c->ts.u.derived->backend_decl;
else
{
if (c->ts.type == BT_CHARACTER)
{
/* Evaluate the string length. */
- gfc_conv_const_charlen (c->ts.cl);
- gcc_assert (c->ts.cl->backend_decl);
+ gfc_conv_const_charlen (c->ts.u.cl);
+ gcc_assert (c->ts.u.cl->backend_decl);
}
field_type = gfc_typenode_for_spec (&c->ts);
/* This returns an array descriptor type. Initialization may be
required. */
- if (c->dimension)
+ if (c->attr.dimension && !c->attr.proc_pointer)
{
- if (c->pointer || c->allocatable)
+ if (c->attr.pointer || c->attr.allocatable)
{
+ enum gfc_array_kind akind;
+ if (c->attr.pointer)
+ akind = GFC_ARRAY_POINTER;
+ else
+ akind = GFC_ARRAY_ALLOCATABLE;
/* Pointers to arrays aren't actually pointer types. The
descriptors are separate, but the data is common. */
- field_type = gfc_build_array_type (field_type, c->as);
+ field_type = gfc_build_array_type (field_type, c->as, akind,
+ !c->attr.target
+ && !c->attr.pointer);
}
else
field_type = gfc_get_nodesc_array_type (field_type, c->as,
- PACKED_STATIC);
+ PACKED_STATIC,
+ !c->attr.target);
}
- else if (c->pointer)
+ else if ((c->attr.pointer || c->attr.allocatable)
+ && !c->attr.proc_pointer)
field_type = build_pointer_type (field_type);
field = gfc_add_field_to_struct (&fieldlist, typenode,
- get_identifier (c->name),
- field_type);
+ get_identifier (c->name), field_type);
if (c->loc.lb)
gfc_set_decl_location (field, &c->loc);
else if (derived->declared_at.lb)
/* Now we have the final fieldlist. Record it, then lay out the
derived type, including the fields. */
TYPE_FIELDS (typenode) = fieldlist;
+ if (canonical)
+ TYPE_CANONICAL (typenode) = canonical;
gfc_finish_type (typenode);
gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
+ if (derived->module && derived->ns->proc_name
+ && derived->ns->proc_name->attr.flavor == FL_MODULE)
+ {
+ if (derived->ns->proc_name->backend_decl
+ && TREE_CODE (derived->ns->proc_name->backend_decl)
+ == NAMESPACE_DECL)
+ {
+ TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl;
+ DECL_CONTEXT (TYPE_STUB_DECL (typenode))
+ = derived->ns->proc_name->backend_decl;
+ }
+ }
derived->backend_decl = typenode;
- /* Add this backend_decl to all the other, equal derived types. */
- for (dt = gfc_derived_types; dt; dt = dt->next)
- copy_dt_decls_ifequal (derived, dt->derived);
+copy_derived_types:
+
+ for (dt = gfc_derived_types; dt; dt = dt->next)
+ copy_dt_decls_ifequal (derived, dt->derived, false);
return derived->backend_decl;
}
if (sym->attr.dimension)
return 1;
- if (sym->ts.type == BT_CHARACTER)
+ if (sym->ts.type == BT_CHARACTER
+ && !sym->attr.is_bind_c
+ && (!sym->attr.result
+ || !sym->ns->proc_name
+ || !sym->ns->proc_name->attr.is_bind_c))
return 1;
/* Possibly return complex numbers by reference for g77 compatibility.
if (el == el2)
{
- decl = build_decl (FIELD_DECL,
+ decl = build_decl (input_location,
+ FIELD_DECL,
get_identifier (el->sym->result->name),
gfc_sym_type (el->sym->result));
DECL_CONTEXT (decl) = type;
int nstr;
int alternate_return;
- /* Make sure this symbol is a function or a subroutine. */
- gcc_assert (sym->attr.flavor == FL_PROCEDURE);
+ /* Make sure this symbol is a function, a subroutine or the main
+ program. */
+ gcc_assert (sym->attr.flavor == FL_PROCEDURE
+ || sym->attr.flavor == FL_PROGRAM);
if (sym->backend_decl)
return TREE_TYPE (sym->backend_decl);
typelist = gfc_chainon_list (typelist, gfc_array_index_type);
}
+ if (sym->result)
+ arg = sym->result;
+ else
+ arg = sym;
+
+ if (arg->ts.type == BT_CHARACTER)
+ gfc_conv_const_charlen (arg->ts.u.cl);
+
/* Some functions we use an extra parameter for the return value. */
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_COMPLEX
|| arg->attr.dimension
/* Evaluate constant character lengths here so that they can be
included in the type. */
if (arg->ts.type == BT_CHARACTER)
- gfc_conv_const_charlen (arg->ts.cl);
+ gfc_conv_const_charlen (arg->ts.u.cl);
if (arg->attr.flavor == FL_PROCEDURE)
{
Contained procedures could pass by value as these are never
used without an explicit interface, and cannot be passed as
actual parameters for a dummy procedure. */
- if (arg->ts.type == BT_CHARACTER)
+ if (arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
nstr++;
typelist = gfc_chainon_list (typelist, type);
}
type = gfc_typenode_for_spec (&sym->ts);
sym->ts.kind = gfc_default_real_kind;
}
+ else if (sym->result && sym->result->attr.proc_pointer)
+ /* Procedure pointer return values. */
+ {
+ if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0)
+ {
+ /* Unset proc_pointer as gfc_get_function_type
+ is called recursively. */
+ sym->result->attr.proc_pointer = 0;
+ type = build_pointer_type (gfc_get_function_type (sym->result));
+ sym->result->attr.proc_pointer = 1;
+ }
+ else
+ type = gfc_sym_type (sym->result);
+ }
else
type = gfc_sym_type (sym);
}
/* Handle TImode as a special case because it is used by some backends
- (eg. ARM) even though it is not available for normal use. */
+ (e.g. ARM) even though it is not available for normal use. */
#if HOST_BITS_PER_WIDE_INT >= 64
if (bits == TYPE_PRECISION (intTI_type_node))
return intTI_type_node;
return NULL_TREE;
}
+/* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
+ in that case. */
+
+bool
+gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
+{
+ int rank, dim;
+ bool indirect = false;
+ tree etype, ptype, field, t, base_decl;
+ tree data_off, dim_off, dim_size, elem_size;
+ tree lower_suboff, upper_suboff, stride_suboff;
+
+ if (! GFC_DESCRIPTOR_TYPE_P (type))
+ {
+ if (! POINTER_TYPE_P (type))
+ return false;
+ type = TREE_TYPE (type);
+ if (! GFC_DESCRIPTOR_TYPE_P (type))
+ return false;
+ indirect = true;
+ }
+
+ rank = GFC_TYPE_ARRAY_RANK (type);
+ if (rank >= (int) (sizeof (info->dimen) / sizeof (info->dimen[0])))
+ return false;
+
+ etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+ gcc_assert (POINTER_TYPE_P (etype));
+ etype = TREE_TYPE (etype);
+ gcc_assert (TREE_CODE (etype) == ARRAY_TYPE);
+ etype = TREE_TYPE (etype);
+ /* Can't handle variable sized elements yet. */
+ if (int_size_in_bytes (etype) <= 0)
+ return false;
+ /* Nor non-constant lower bounds in assumed shape arrays. */
+ if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
+ {
+ for (dim = 0; dim < rank; dim++)
+ if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
+ || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST)
+ return false;
+ }
+
+ memset (info, '\0', sizeof (*info));
+ info->ndimensions = rank;
+ info->element_type = etype;
+ ptype = build_pointer_type (gfc_array_index_type);
+ base_decl = GFC_TYPE_ARRAY_BASE_DECL (type, indirect);
+ if (!base_decl)
+ {
+ base_decl = build_decl (input_location, VAR_DECL, NULL_TREE,
+ indirect ? build_pointer_type (ptype) : ptype);
+ GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl;
+ }
+ info->base_decl = base_decl;
+ if (indirect)
+ base_decl = build1 (INDIRECT_REF, ptype, base_decl);
+
+ if (GFC_TYPE_ARRAY_SPAN (type))
+ elem_size = GFC_TYPE_ARRAY_SPAN (type);
+ else
+ elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
+ field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type));
+ data_off = byte_position (field);
+ field = TREE_CHAIN (field);
+ field = TREE_CHAIN (field);
+ field = TREE_CHAIN (field);
+ dim_off = byte_position (field);
+ dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field)));
+ field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field)));
+ stride_suboff = byte_position (field);
+ field = TREE_CHAIN (field);
+ lower_suboff = byte_position (field);
+ field = TREE_CHAIN (field);
+ upper_suboff = byte_position (field);
+
+ t = base_decl;
+ if (!integer_zerop (data_off))
+ t = build2 (POINTER_PLUS_EXPR, ptype, t, data_off);
+ t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
+ info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
+ if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
+ info->allocated = build2 (NE_EXPR, boolean_type_node,
+ info->data_location, null_pointer_node);
+ else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER)
+ info->associated = build2 (NE_EXPR, boolean_type_node,
+ info->data_location, null_pointer_node);
+
+ for (dim = 0; dim < rank; dim++)
+ {
+ t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
+ size_binop (PLUS_EXPR, dim_off, lower_suboff));
+ t = build1 (INDIRECT_REF, gfc_array_index_type, t);
+ info->dimen[dim].lower_bound = t;
+ t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
+ size_binop (PLUS_EXPR, dim_off, upper_suboff));
+ t = build1 (INDIRECT_REF, gfc_array_index_type, t);
+ info->dimen[dim].upper_bound = t;
+ if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
+ {
+ /* Assumed shape arrays have known lower bounds. */
+ info->dimen[dim].upper_bound
+ = build2 (MINUS_EXPR, gfc_array_index_type,
+ info->dimen[dim].upper_bound,
+ info->dimen[dim].lower_bound);
+ info->dimen[dim].lower_bound
+ = fold_convert (gfc_array_index_type,
+ GFC_TYPE_ARRAY_LBOUND (type, dim));
+ info->dimen[dim].upper_bound
+ = build2 (PLUS_EXPR, gfc_array_index_type,
+ info->dimen[dim].lower_bound,
+ info->dimen[dim].upper_bound);
+ }
+ t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
+ size_binop (PLUS_EXPR, dim_off, stride_suboff));
+ t = build1 (INDIRECT_REF, gfc_array_index_type, t);
+ t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
+ info->dimen[dim].stride = t;
+ dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
+ }
+
+ return true;
+}
+
#include "gt-fortran-trans-types.h"
OSDN Git Service
