/* Backend support for Fortran 95 basic types and derived types.
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ 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>
/* 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. */
#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
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;
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;
}
static tree
gfc_build_array_type (tree type, gfc_array_spec * as,
- enum gfc_array_kind akind)
+ enum gfc_array_kind akind, bool restricted)
{
tree lbound[GFC_MAX_DIMENSIONS];
tree ubound[GFC_MAX_DIMENSIONS];
if (as->type == AS_ASSUMED_SHAPE)
akind = GFC_ARRAY_ASSUMED_SHAPE;
- return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0, akind);
+ return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound,
+ ubound, 0, akind, restricted);
}
\f
/* Returns the struct descriptor_dimension 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;
/* 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)
{
/* 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 (input_location,
- FIELD_DECL, get_identifier ("data"), ptr_type_node);
+ FIELD_DECL, get_identifier ("data"),
+ restricted ? prvoid_type_node : ptr_type_node);
DECL_CONTEXT (decl) = fat_type;
fieldlist = decl;
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 (input_location,
FIELD_DECL, get_identifier ("dim"), arraytype);
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,
+gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
tree * ubound, int packed,
- enum gfc_array_kind akind)
+ enum gfc_array_kind akind, bool restricted)
{
- char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
+ 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);
+ 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);
type_name = IDENTIFIER_POINTER (tmp);
else
type_name = "unknown";
- sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
+ sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen + codimen,
GFC_MAX_SYMBOL_LEN, type_name);
TYPE_NAME (fat_type) = get_identifier (name);
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
{
tree type;
int byref;
+ bool restricted;
/* Procedure Pointers inside COMMON blocks. */
if (sym->attr.proc_pointer && sym->attr.in_common)
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
{
akind = GFC_ARRAY_POINTER;
else if (sym->attr.allocatable)
akind = GFC_ARRAY_ALLOCATABLE;
- type = gfc_build_array_type (type, sym->as, akind);
+ 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);
to_cm->backend_decl = from_cm->backend_decl;
if ((!from_cm->attr.pointer || from_gsym)
&& from_cm->ts.type == BT_DERIVED)
- gfc_get_derived_type (to_cm->ts.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;
gfc_get_ppc_type (gfc_component* c)
{
tree t;
- if (c->attr.function && !c->attr.dimension)
- {
- if (c->ts.type == BT_DERIVED)
- t = c->ts.derived->backend_decl;
- else
- t = gfc_typenode_for_spec (&c->ts);
- }
+
+ /* 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;
- /* TODO: Build argument list. */
+
return build_pointer_type (build_function_type (t, NULL_TREE));
}
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;
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;
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->attr.pointer && !c->attr.proc_pointer)
- || c->ts.derived->backend_decl == NULL)
- c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
+ || 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;
{
if (c->attr.proc_pointer)
field_type = gfc_get_ppc_type (c);
- else if (c->ts.type == BT_DERIVED)
- field_type = c->ts.derived->backend_decl;
+ 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);
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, akind);
+ 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->attr.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;
- TYPE_CANONICAL (typenode) = canonical;
+ if (canonical)
+ TYPE_CANONICAL (typenode) = canonical;
gfc_finish_type (typenode);
gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
arg = sym;
if (arg->ts.type == BT_CHARACTER)
- gfc_conv_const_charlen (arg->ts.cl);
+ 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))
/* 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)
{
int rank, dim;
bool indirect = false;
tree etype, ptype, field, t, base_decl;
- tree data_off, offset_off, dim_off, dim_size, elem_size;
+ tree data_off, dim_off, dim_size, elem_size;
tree lower_suboff, upper_suboff, stride_suboff;
if (! GFC_DESCRIPTOR_TYPE_P (type))
field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type));
data_off = byte_position (field);
field = TREE_CHAIN (field);
- offset_off = byte_position (field);
field = TREE_CHAIN (field);
field = TREE_CHAIN (field);
dim_off = byte_position (field);
OSDN Git Service
