/* 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 */
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;
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;
+
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.
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;
+
+ /* 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.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;
/* 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;
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;
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);
if (sym->attr.result || sym->attr.function)
return 0;
- if (sym->attr.pointer || sym->attr.allocatable)
- return 0;
-
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;
+
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
- if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
- return (GFC_TYPE_ARRAY_DTYPE (type));
+ if (GFC_TYPE_ARRAY_DTYPE (type))
+ return GFC_TYPE_ARRAY_DTYPE (type);
- /* TODO: Correctly identify LOGICAL types. */
- switch (TREE_CODE (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;
}
gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
- size = TYPE_SIZE_UNIT (type);
+ 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;
}
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. */
gcc_assert (INTEGER_CST_P (stride));
}
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)
+ if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
byref = 1;
else
byref = 0;
/* 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;
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)
- 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)
required. */
if (c->dimension)
{
- if (c->pointer)
+ if (c->pointer || c->allocatable)
{
/* Pointers to arrays aren't actually pointer types. The
- descriptors are seperate, but the data is common. */
+ 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);
- 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)
{
if (!sym->attr.function)
return 0;
- gcc_assert (sym->attr.function);
-
- if (sym->result)
- sym = sym->result;
-
if (sym->attr.dimension)
return 1;
if (sym->ts.type == BT_CHARACTER)
return 1;
- /* Possibly return complex numbers by reference for g77 compatibility. */
+ /* 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)
{
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.
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 = 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);
OSDN Git Service
