/* Backend support for Fortran 95 basic types and derived types.
- Copyright (C) 2002, 2003, 2004 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 */
#include "trans-types.h"
#include "trans-const.h"
#include "real.h"
-#include <assert.h>
\f
#if (GFC_MAX_DIMENSIONS < 10)
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 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];
/* The default kinds of the various types. */
int gfc_default_integer_kind;
+int gfc_max_integer_kind;
int gfc_default_real_kind;
int gfc_default_double_kind;
int gfc_default_character_kind;
if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
continue;
- if (i_index == MAX_INT_KINDS)
- abort ();
+ gcc_assert (i_index != MAX_INT_KINDS);
/* Let the kind equal the bit size divided by 8. This insulates the
programmer from the underlying byte size. */
i_index += 1;
}
+ /* Set the maximum integer kind. Used with at least BOZ constants. */
+ gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
+
for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
{
const struct real_format *fmt = REAL_MODE_FORMAT (mode);
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.
saw_r16 = true;
/* Careful we don't stumble a wierd internal mode. */
- if (r_index > 0 && gfc_real_kinds[r_index-1].kind == kind)
- abort ();
+ gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
/* Or have too many modes for the allocated space. */
- if (r_index == MAX_REAL_KINDS)
- abort ();
+ gcc_assert (r_index != MAX_REAL_KINDS);
gfc_real_kinds[r_index].kind = kind;
gfc_real_kinds[r_index].radix = fmt->b;
gfc_real_kinds[r_index].digits = fmt->p;
gfc_real_kinds[r_index].min_exponent = fmt->emin;
gfc_real_kinds[r_index].max_exponent = fmt->emax;
+ 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;
}
/* Choose the default integer kind. We choose 4 unless the user
directs us otherwise. */
- if (gfc_option.i8)
+ if (gfc_option.flag_default_integer)
{
if (!saw_i8)
- fatal_error ("integer kind=8 not available for -i8 option");
+ fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
gfc_default_integer_kind = 8;
}
else if (saw_i4)
gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
/* Choose the default real kind. Again, we choose 4 when possible. */
- if (gfc_option.r8)
+ if (gfc_option.flag_default_real)
{
if (!saw_r8)
- fatal_error ("real kind=8 not available for -r8 option");
+ fatal_error ("real kind=8 not available for -fdefault-real-8 option");
gfc_default_real_kind = 8;
}
else if (saw_r4)
else
gfc_default_real_kind = gfc_real_kinds[0].kind;
- /* Choose the default double kind. If -r8 is specified, we use kind=16,
- if it's available, otherwise we do not change anything. */
- if (gfc_option.r8 && saw_r16)
+ /* Choose the default double kind. If -fdefault-real and -fdefault-double
+ are specified, we use kind=8, if it's available. If -fdefault-real is
+ specified without -fdefault-double, we use kind=16, if it's available.
+ Otherwise we do not change anything. */
+ if (gfc_option.flag_default_double && !gfc_option.flag_default_real)
+ fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
+
+ if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8)
+ gfc_default_double_kind = 8;
+ else if (gfc_option.flag_default_real && saw_r16)
gfc_default_double_kind = 16;
else if (saw_r4 && saw_r8)
gfc_default_double_kind = 8;
return LONG_TYPE_SIZE;
if (strcmp (SIZE_TYPE, "short unsigned int") == 0)
return SHORT_TYPE_SIZE;
- abort ();
+ gcc_unreachable ();
#else
return LONG_TYPE_SIZE;
#endif
PUSH_TYPE (name_buf, type);
}
- gfc_character1_type_node = build_type_variant (signed_char_type_node, 0, 0);
+ gfc_character1_type_node = build_type_variant (unsigned_char_type_node,
+ 0, 0);
PUSH_TYPE ("char", gfc_character1_type_node);
PUSH_TYPE ("byte", unsigned_char_type_node);
pchar_type_node = build_pointer_type (gfc_character1_type_node);
gfc_array_index_type = gfc_get_int_type (gfc_index_integer_kind);
+ /* We cannot use gfc_index_zero_node in definition of gfc_array_range_type,
+ since this function is called before gfc_init_constants. */
+ gfc_array_range_type
+ = build_range_type (gfc_array_index_type,
+ build_int_cst (gfc_array_index_type, 0),
+ NULL_TREE);
/* The maximum array element size that can be handled is determined
by the number of bits available to store this field in the array
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. */
gfc_validate_kind (BT_CHARACTER, kind, false);
- bounds = build_range_type (gfc_array_index_type, gfc_index_one_node, len);
+ bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
type = build_array_type (gfc_character1_type_node, bounds);
TYPE_STRING_FLAG (type) = 1;
switch (spec->type)
{
case BT_UNKNOWN:
- abort ();
- break;
+ gcc_unreachable ();
case BT_INTEGER:
basetype = gfc_get_int_type (spec->kind);
break;
default:
- abort ();
- break;
+ gcc_unreachable ();
}
return basetype;
}
{
if (TREE_CODE (type) == POINTER_TYPE)
type = TREE_TYPE (type);
- assert (TREE_CODE (type) == ARRAY_TYPE);
+ gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
element = TREE_TYPE (type);
}
else
{
- assert (GFC_DESCRIPTOR_TYPE_P (type));
- element = TREE_TYPE (TYPE_FIELDS (type));
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ element = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
- assert (TREE_CODE (element) == POINTER_TYPE);
+ gcc_assert (TREE_CODE (element) == POINTER_TYPE);
element = TREE_TYPE (element);
- assert (TREE_CODE (element) == ARRAY_TYPE);
+ gcc_assert (TREE_CODE (element) == ARRAY_TYPE);
element = TREE_TYPE (element);
}
the calculation for stride02 would overflow. This may still work, but
I haven't checked, and it relies on the overflow doing the right thing.
- The way to fix this problem is to access alements as follows:
+ The way to fix this problem is to access elements as follows:
data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
Obviously this is much slower. I will make this a compile time option,
something like -fsmall-array-offsets. Mixing code compiled with and without
int
gfc_is_nodesc_array (gfc_symbol * sym)
{
- assert (sym->attr.dimension);
+ gcc_assert (sym->attr.dimension);
/* We only want local arrays. */
if (sym->attr.pointer || sym->attr.allocatable)
if (sym->attr.result || sym->attr.function)
return 0;
- if (sym->attr.pointer || sym->attr.allocatable)
- return 0;
-
- assert (sym->as->type == AS_EXPLICIT);
+ gcc_assert (sym->as->type == AS_EXPLICIT);
return 1;
}
return type;
}
-static tree
-gfc_get_dtype (tree type, int rank)
+
+/* Return the DTYPE for an array. This describes the type and type parameters
+ of the array. */
+/* TODO: Only call this when the value is actually used, and make all the
+ unknown cases abort. */
+
+tree
+gfc_get_dtype (tree type)
{
tree size;
int n;
HOST_WIDE_INT i;
tree tmp;
tree dtype;
+ tree etype;
+ int rank;
- if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
- return (GFC_TYPE_ARRAY_DTYPE (type));
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
- /* TODO: Correctly identify LOGICAL types. */
- switch (TREE_CODE (type))
+ if (GFC_TYPE_ARRAY_DTYPE (type))
+ return GFC_TYPE_ARRAY_DTYPE (type);
+
+ rank = GFC_TYPE_ARRAY_RANK (type);
+ etype = gfc_get_element_type (type);
+
+ switch (TREE_CODE (etype))
{
case INTEGER_TYPE:
n = GFC_DTYPE_INTEGER;
n = GFC_DTYPE_COMPLEX;
break;
- /* Arrays have already been dealt with. */
+ /* We will never have arrays of arrays. */
case RECORD_TYPE:
n = GFC_DTYPE_DERIVED;
break;
return gfc_index_zero_node;
}
- assert (rank <= GFC_DTYPE_RANK_MASK);
- size = TYPE_SIZE_UNIT (type);
+ gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
+ size = TYPE_SIZE_UNIT (etype);
i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
if (size && INTEGER_CST_P (size))
if (size && !INTEGER_CST_P (size))
{
tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
- tmp = fold (build2 (LSHIFT_EXPR, gfc_array_index_type, size, tmp));
- dtype = fold (build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype));
+ tmp = fold_build2 (LSHIFT_EXPR, gfc_array_index_type, size, tmp);
+ dtype = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype);
}
/* If we don't know the size we leave it as zero. This should never happen
for anything that is actually used. */
/* TODO: Check this is actually true, particularly when repacking
assumed size parameters. */
+ GFC_TYPE_ARRAY_DTYPE (type) = dtype;
return dtype;
}
mpz_init (delta);
/* We don't use build_array_type because this does not include include
- lang-specific information (ie. the bounds of the array) when checking
+ lang-specific information (i.e. the bounds of the array) when checking
for duplicates. */
type = make_node (ARRAY_TYPE);
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;
+ GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
NULL_TREE);
/* TODO: use main type if it is unbounded. */
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) = gfc_get_dtype (etype, dimen);
+ 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;
if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
{
- tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, upper, lower));
- tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type, tmp,
- gfc_index_one_node));
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower);
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
+ gfc_index_one_node);
stride =
- fold (build2 (MULT_EXPR, gfc_array_index_type, tmp, stride));
+ fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
/* Check the folding worked. */
- assert (INTEGER_CST_P (stride));
+ gcc_assert (INTEGER_CST_P (stride));
}
else
stride = NULL_TREE;
}
GFC_TYPE_ARRAY_SIZE (fat_type) = stride;
+
/* 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,
- build_range_type (gfc_array_index_type,
- gfc_index_zero_node, NULL_TREE));
+ build_array_type (etype, gfc_array_range_type);
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
return TREE_TYPE (sym->backend_decl);
}
- /* The frontend doesn't set all the attributes for a function with an
- explicit result value, so we use that instead when present. */
- if (sym->attr.function && sym->result)
- sym = sym->result;
-
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)
byref = 1;
/* If this is a character argument of unknown length, just use the
base type. */
if (sym->ts.type != BT_CHARACTER
- || !(sym->attr.dummy || sym->attr.function || sym->attr.result)
+ || !(sym->attr.dummy || sym->attr.function)
|| sym->ts.cl->backend_decl)
{
type = gfc_get_nodesc_array_type (type, sym->as,
}
-/* 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;
- assert (derived && derived->attr.flavor == FL_DERIVED);
+ gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
/* derived->backend_decl != 0 means we saw it before, but its
components' backend_decl may have not been built. */
}
else
{
+ /* In a module, if an equal derived type is already available in the
+ specification block, 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. Non-module structures,
+ need to be built, if found, because the order of visits to the
+ namespaces is different. */
+
+ for (ns = derived->ns->parent; ns; ns = ns->parent)
+ {
+ for (dt = ns->derived_types; dt; dt = dt->next)
+ {
+ if (derived->module == NULL
+ && 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)
- field_type = c->ts.derived->backend_decl;
- else
- {
- /* Build the type node. */
- 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;
- }
- }
+ if (c->ts.type == BT_DERIVED)
+ field_type = c->ts.derived->backend_decl;
else
{
if (c->ts.type == BT_CHARACTER)
{
/* Evaluate the string length. */
gfc_conv_const_charlen (c->ts.cl);
- assert (c->ts.cl->backend_decl);
+ gcc_assert (c->ts.cl->backend_decl);
}
field_type = gfc_typenode_for_spec (&c->ts);
}
- /* This returns an array descriptor type. Initialisation may be
+ /* This returns an array descriptor type. Initialization may be
required. */
if (c->dimension)
{
if (c->pointer)
{
- /* Pointers to arrays aren't actualy pointer types. The
- descriptors are seperate, but the data is common. */
+ /* 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);
}
else
DECL_PACKED (field) |= TYPE_PACKED (typenode);
- 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 namespace. */
+ for (dt = derived->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)
{
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");
- /* Possibly return derived types by reference. */
+ /* Possibly return complex numbers by reference for g77 compatibility.
+ We don't do this for calls to intrinsics (as the library uses the
+ -fno-f2c calling convention), nor for calls to functions which always
+ require an explicit interface, as no compatibility problems can
+ arise there. */
+ if (gfc_option.flag_f2c
+ && sym->ts.type == BT_COMPLEX
+ && !sym->attr.intrinsic && !sym->attr.always_explicit)
+ return 1;
+
return 0;
}
\f
+static tree
+gfc_get_mixed_entry_union (gfc_namespace *ns)
+{
+ tree type;
+ tree decl;
+ tree fieldlist;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ gfc_entry_list *el, *el2;
+
+ gcc_assert (ns->proc_name->attr.mixed_entry_master);
+ gcc_assert (memcmp (ns->proc_name->name, "master.", 7) == 0);
+
+ snprintf (name, GFC_MAX_SYMBOL_LEN, "munion.%s", ns->proc_name->name + 7);
+
+ /* Build the type node. */
+ type = make_node (UNION_TYPE);
+
+ TYPE_NAME (type) = get_identifier (name);
+ fieldlist = NULL;
+
+ for (el = ns->entries; el; el = el->next)
+ {
+ /* Search for duplicates. */
+ for (el2 = ns->entries; el2 != el; el2 = el2->next)
+ if (el2->sym->result == el->sym->result)
+ break;
+
+ if (el == el2)
+ {
+ decl = build_decl (FIELD_DECL,
+ get_identifier (el->sym->result->name),
+ gfc_sym_type (el->sym->result));
+ DECL_CONTEXT (decl) = type;
+ fieldlist = chainon (fieldlist, decl);
+ }
+ }
+
+ /* Finish off the type. */
+ TYPE_FIELDS (type) = fieldlist;
+
+ gfc_finish_type (type);
+ return type;
+}
+\f
tree
gfc_get_function_type (gfc_symbol * sym)
{
int alternate_return;
/* Make sure this symbol is a function or a subroutine. */
- assert (sym->attr.flavor == FL_PROCEDURE);
+ gcc_assert (sym->attr.flavor == FL_PROCEDURE);
if (sym->backend_decl)
return TREE_TYPE (sym->backend_decl);
gfc_conv_const_charlen (arg->ts.cl);
type = gfc_sym_type (arg);
- if (arg->ts.type == BT_DERIVED
+ if (arg->ts.type == BT_COMPLEX
|| arg->attr.dimension
|| arg->ts.type == BT_CHARACTER)
type = build_reference_type (type);
The problem arises if a function is called via an implicit
prototype. In this situation the INTENT is not known.
For this reason all parameters to global functions must be
- passed by reference. Passing by value would potentialy
+ passed by reference. Passing by value would potentially
generate bad code. Worse there would be no way of telling that
this code was bad, except that it would give incorrect results.
type = integer_type_node;
else if (!sym->attr.function || gfc_return_by_reference (sym))
type = void_type_node;
+ else if (sym->attr.mixed_entry_master)
+ type = gfc_get_mixed_entry_union (sym->ns);
else
type = gfc_sym_type (sym);
return NULL_TREE;
}
else
- abort ();
+ return NULL_TREE;
for (i = 0; i <= MAX_REAL_KINDS; ++i)
{
OSDN Git Service
