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 pvoid_type_node;
tree ppvoid_type_node;
tree pchar_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];
/* 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;
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
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;
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. */
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;
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)
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,
if (!sym->attr.function)
return 0;
- 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.
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
