/* Backend support for Fortran 95 basic types and derived types.
- Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
+ Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
/* trans-types.c -- gfortran backend types */
tree gfc_array_index_type;
tree gfc_array_range_type;
+tree gfc_character1_type_node;
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;
+static GTY(()) tree gfc_array_descriptor_base[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_integer_types[MAX_INT_KINDS + 1];
static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];
-#define MAX_REAL_KINDS 4
+#define MAX_REAL_KINDS 5
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_default_complex_kind;
int gfc_c_int_kind;
+/* The kind size used for record offsets. If the target system supports
+ kind=8, this will be set to 8, otherwise it is set to 4. */
+int gfc_intio_kind;
+
+/* The size of the numeric storage unit and character storage unit. */
+int gfc_numeric_storage_size;
+int gfc_character_storage_size;
+
/* Query the target to determine which machine modes are available for
computation. Choose KIND numbers for them. */
i_index += 1;
}
+ /* Set the kind used to match GFC_INT_IO in libgfortran. This is
+ used for large file access. */
+
+ if (saw_i8)
+ gfc_intio_kind = 8;
+ else
+ gfc_intio_kind = 4;
+
+ /* If we do not at least have kind = 4, everything is pointless. */
+ gcc_assert(saw_i4);
+
/* Set the maximum integer kind. Used with at least BOZ constants. */
gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
if (!targetm.scalar_mode_supported_p (mode))
continue;
+ /* Only let float/double/long double go through because the fortran
+ library assumes these are the only floating point types. */
+
+ if (mode != TYPE_MODE (float_type_node)
+ && (mode != TYPE_MODE (double_type_node))
+ && (mode != TYPE_MODE (long_double_type_node)))
+ continue;
+
/* Let the kind equal the precision divided by 8, rounding up. Again,
this insulates the programmer from the underlying byte size.
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;
+ if (fmt->pnan < fmt->p)
+ /* This is an IBM extended double format (or the MIPS variant)
+ made up of two IEEE doubles. The value of the long double is
+ the sum of the values of the two parts. The most significant
+ part is required to be the value of the long double rounded
+ to the nearest double. If we use emax of 1024 then we can't
+ represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
+ rounding will make the most significant part overflow. */
+ gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;
gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
r_index += 1;
}
if (!saw_i8)
fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
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
+ be issued when NUMERIC_STORAGE_SIZE is used. */
+ gfc_numeric_storage_size = 4 * 8;
}
else if (saw_i4)
- gfc_default_integer_kind = 4;
+ {
+ gfc_default_integer_kind = 4;
+ gfc_numeric_storage_size = 4 * 8;
+ }
else
- gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
+ {
+ gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
+ gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
+ }
/* Choose the default real kind. Again, we choose 4 when possible. */
if (gfc_option.flag_default_real)
/* Choose the smallest integer kind for our default character. */
gfc_default_character_kind = gfc_integer_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. */
gfc_index_integer_kind = POINTER_SIZE / 8;
tree
gfc_get_int_type (int kind)
{
- int index = gfc_validate_kind (BT_INTEGER, kind, false);
- return gfc_integer_types[index];
+ int index = gfc_validate_kind (BT_INTEGER, kind, true);
+ return index < 0 ? 0 : gfc_integer_types[index];
}
tree
gfc_get_real_type (int kind)
{
- int index = gfc_validate_kind (BT_REAL, kind, false);
- return gfc_real_types[index];
+ int index = gfc_validate_kind (BT_REAL, kind, true);
+ return index < 0 ? 0 : gfc_real_types[index];
}
tree
gfc_get_complex_type (int kind)
{
- int index = gfc_validate_kind (BT_COMPLEX, kind, false);
- return gfc_complex_types[index];
+ int index = gfc_validate_kind (BT_COMPLEX, kind, true);
+ return index < 0 ? 0 : gfc_complex_types[index];
}
tree
gfc_get_logical_type (int kind)
{
- int index = gfc_validate_kind (BT_LOGICAL, kind, false);
- return gfc_logical_types[index];
+ int index = gfc_validate_kind (BT_LOGICAL, kind, true);
+ return index < 0 ? 0 : gfc_logical_types[index];
}
\f
/* Create a character type with the given kind and length. */
else
{
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
- element = TREE_TYPE (TYPE_FIELDS (type));
+ element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
gcc_assert (TREE_CODE (element) == POINTER_TYPE);
element = TREE_TYPE (element);
return type;
}
+/* Return or create the base type for an array descriptor. */
+
+static tree
+gfc_get_array_descriptor_base (int dimen)
+{
+ tree fat_type, fieldlist, decl, arraytype;
+ char name[16 + GFC_RANK_DIGITS + 1];
+
+ gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
+ if (gfc_array_descriptor_base[dimen - 1])
+ return gfc_array_descriptor_base[dimen - 1];
+
+ /* Build the type node. */
+ fat_type = make_node (RECORD_TYPE);
+
+ sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen);
+ 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_CONTEXT (decl) = fat_type;
+ fieldlist = decl;
+
+ /* Add the base component. */
+ decl = build_decl (FIELD_DECL, get_identifier ("offset"),
+ gfc_array_index_type);
+ DECL_CONTEXT (decl) = fat_type;
+ fieldlist = chainon (fieldlist, decl);
+
+ /* Add the dtype component. */
+ decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
+ gfc_array_index_type);
+ DECL_CONTEXT (decl) = fat_type;
+ fieldlist = chainon (fieldlist, decl);
+
+ /* Build the array type for the stride and bound components. */
+ 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;
+ fieldlist = chainon (fieldlist, decl);
+
+ /* Finish off the type. */
+ TYPE_FIELDS (fat_type) = fieldlist;
+
+ gfc_finish_type (fat_type);
+
+ gfc_array_descriptor_base[dimen - 1] = fat_type;
+ return fat_type;
+}
/* Build an array (descriptor) type with given bounds. */
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];
+ tree fat_type, base_type, arraytype, lower, upper, stride, tmp;
const char *typename;
- tree lower;
- tree upper;
- tree stride;
- tree tmp;
+ int n;
- /* Build the type node. */
- 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;
+ base_type = gfc_get_array_descriptor_base (dimen);
+ fat_type = build_variant_type_copy (base_type);
tmp = TYPE_NAME (etype);
if (tmp && TREE_CODE (tmp) == TYPE_DECL)
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);
+ 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;
/* Build an array descriptor record 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;
stride = NULL_TREE;
}
GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
+
/* TODO: known offsets for descriptors. */
GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
arraytype = build_pointer_type (arraytype);
GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
- /* The pointer to the array data. */
- decl = build_decl (FIELD_DECL, get_identifier ("data"), arraytype);
-
- DECL_CONTEXT (decl) = fat_type;
- /* Add the data member as the first element of the descriptor. */
- fieldlist = decl;
-
- /* Add the base component. */
- decl = build_decl (FIELD_DECL, get_identifier ("offset"),
- gfc_array_index_type);
- DECL_CONTEXT (decl) = fat_type;
- fieldlist = chainon (fieldlist, decl);
-
- /* Add the dtype component. */
- decl = build_decl (FIELD_DECL, get_identifier ("dtype"),
- gfc_array_index_type);
- DECL_CONTEXT (decl) = fat_type;
- fieldlist = chainon (fieldlist, decl);
-
- /* Build the array type for the stride and bound components. */
- 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);
-
- /* Finish off the type. */
- TYPE_FIELDS (fat_type) = fieldlist;
-
- gfc_finish_type (fat_type);
-
return fat_type;
}
\f
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);
- }
+ /* In the case of a function the fake result variable may have a
+ type different from the function type, so don't return early in
+ that case. */
+ if (sym->backend_decl && !sym->attr.function)
+ return TREE_TYPE (sym->backend_decl);
type = gfc_typenode_for_spec (&sym->ts);
- if (gfc_option.flag_f2c
- && sym->attr.function
- && sym->ts.type == BT_REAL
- && sym->ts.kind == gfc_default_real_kind
- && !sym->attr.always_explicit)
- {
- /* Special case: f2c calling conventions require that (scalar)
- default REAL functions return the C type double instead. */
- sym->ts.kind = gfc_default_double_kind;
- type = gfc_typenode_for_spec (&sym->ts);
- sym->ts.kind = gfc_default_real_kind;
- }
- if (sym->attr.dummy && !sym->attr.function)
+ if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
byref = 1;
else
byref = 0;
}
-/* Build a tree node for a derived type. */
+/* Copy the backend_decl and component backend_decls if
+ the two derived type symbols are "equal", as described
+ in 4.4.2 and resolved by gfc_compare_derived_types. */
+
+static int
+copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
+{
+ gfc_component *to_cm;
+ gfc_component *from_cm;
+
+ if (from->backend_decl == NULL
+ || !gfc_compare_derived_types (from, to))
+ return 0;
+
+ to->backend_decl = from->backend_decl;
+
+ to_cm = to->components;
+ from_cm = from->components;
+
+ /* Copy the component declarations. If a component is itself
+ a derived type, we need a copy of its component declarations.
+ This is done by recursing into gfc_get_derived_type and
+ ensures that the component's component declarations have
+ been built. If it is a character, we need the character
+ length, as well. */
+ for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
+ {
+ to_cm->backend_decl = from_cm->backend_decl;
+ if (from_cm->ts.type == BT_DERIVED)
+ gfc_get_derived_type (to_cm->ts.derived);
+
+ else if (from_cm->ts.type == BT_CHARACTER)
+ to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl;
+ }
+
+ return 1;
+}
+
+
+/* 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
gfc_get_derived_type (gfc_symbol * derived)
{
tree typenode, field, field_type, fieldlist;
gfc_component *c;
+ gfc_dt_list *dt;
+ gfc_namespace * ns;
gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
}
else
{
+ /* If an equal derived type is already available in the parent namespace,
+ use its backend declaration and those of its components, rather than
+ building anew so that potential dummy and actual arguments use the
+ same TREE_TYPE. If an equal type is found without a backend_decl,
+ build the parent version and use it in the current namespace. */
+ if (derived->ns->parent)
+ ns = derived->ns->parent;
+ else if (derived->ns->proc_name
+ && derived->ns->proc_name->ns != derived->ns)
+ /* Derived types in an interface body obtain their parent reference
+ through the proc_name symbol. */
+ ns = derived->ns->proc_name->ns;
+ else
+ /* Sometimes there isn't a parent reference! */
+ ns = NULL;
+
+ for (; ns; ns = ns->parent)
+ {
+ for (dt = ns->derived_types; dt; dt = dt->next)
+ {
+ if (dt->derived == derived)
+ continue;
+
+ if (dt->derived->backend_decl == NULL
+ && gfc_compare_derived_types (dt->derived, derived))
+ gfc_get_derived_type (dt->derived);
+
+ if (copy_dt_decls_ifequal (dt->derived, derived))
+ break;
+ }
+ if (derived->backend_decl)
+ goto other_equal_dts;
+ }
+
/* We see this derived type first time, so build the type node. */
typenode = make_node (RECORD_TYPE);
TYPE_NAME (typenode) = get_identifier (derived->name);
derived->backend_decl = typenode;
}
+ /* Go through the derived type components, building them as
+ necessary. The reason for doing this now is that it is
+ possible to recurse back to this derived type through a
+ pointer component (PR24092). If this happens, the fields
+ will be built and so we can return the type. */
+ for (c = derived->components; c; c = c->next)
+ {
+ if (c->ts.type != BT_DERIVED)
+ continue;
+
+ if (!c->pointer || c->ts.derived->backend_decl == NULL)
+ c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
+ }
+
+ if (TYPE_FIELDS (derived->backend_decl))
+ return derived->backend_decl;
+
/* Build the type member list. Install the newly created RECORD_TYPE
node as DECL_CONTEXT of each FIELD_DECL. */
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)
- /* We already saw this derived type so use the exiting type.
- It doesn't matter if it is incomplete. */
- field_type = c->ts.derived->backend_decl;
- else
- /* Recurse into the type. */
- field_type = gfc_get_derived_type (c->ts.derived);
- }
+ if (c->ts.type == BT_DERIVED)
+ field_type = c->ts.derived->backend_decl;
else
{
if (c->ts.type == BT_CHARACTER)
required. */
if (c->dimension)
{
- if (c->pointer)
+ if (c->pointer || c->allocatable)
{
/* Pointers to arrays aren't actually pointer types. The
descriptors are separate, but the data is common. */
DECL_PACKED (field) |= TYPE_PACKED (typenode);
- gcc_assert (!c->backend_decl);
- c->backend_decl = field;
+ gcc_assert (field);
+ if (!c->backend_decl)
+ c->backend_decl = field;
}
/* Now we have the final fieldlist. Record it, then lay out the
derived->backend_decl = typenode;
- return typenode;
+other_equal_dts:
+ /* Add this backend_decl to all the other, equal derived types and
+ their components in this and sibling namespaces. */
+ ns = derived->ns->parent ? derived->ns->parent->contained : derived->ns;
+ for (; ns; ns = ns->sibling)
+ for (dt = ns->derived_types; dt; dt = dt->next)
+ copy_dt_decls_ifequal (derived, dt->derived);
+
+ return derived->backend_decl;
}
-\f
+
+
int
gfc_return_by_reference (gfc_symbol * sym)
{
this code was bad, except that it would give incorrect results.
Contained procedures could pass by value as these are never
- used without an explicit interface, and connot be passed as
+ used without an explicit interface, and cannot be passed as
actual parameters for a dummy procedure. */
if (arg->ts.type == BT_CHARACTER)
nstr++;
type = void_type_node;
else if (sym->attr.mixed_entry_master)
type = gfc_get_mixed_entry_union (sym->ns);
+ else if (gfc_option.flag_f2c
+ && sym->ts.type == BT_REAL
+ && sym->ts.kind == gfc_default_real_kind
+ && !sym->attr.always_explicit)
+ {
+ /* Special case: f2c calling conventions require that (scalar)
+ default REAL functions return the C type double instead. f2c
+ compatibility is only an issue with functions that don't
+ require an explicit interface, as only these could be
+ implemented in Fortran 77. */
+ sym->ts.kind = gfc_default_double_kind;
+ type = gfc_typenode_for_spec (&sym->ts);
+ sym->ts.kind = gfc_default_real_kind;
+ }
else
type = gfc_sym_type (sym);