/* 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_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. */
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++;
OSDN Git Service
