/* Backend support for Fortran 95 basic types and derived types.
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
- Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
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, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* trans-types.c -- gfortran backend types */
#include "trans-types.h"
#include "trans-const.h"
#include "real.h"
+#include "flags.h"
+#include "dwarf2out.h"
\f
#if (GFC_MAX_DIMENSIONS < 10)
tree pvoid_type_node;
tree ppvoid_type_node;
tree pchar_type_node;
+tree pfunc_type_node;
tree gfc_charlen_type_node;
static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];
static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];
+#define MAX_CHARACTER_KINDS 2
+gfc_character_info gfc_character_kinds[MAX_CHARACTER_KINDS + 1];
+static GTY(()) tree gfc_character_types[MAX_CHARACTER_KINDS + 1];
+static GTY(()) tree gfc_pcharacter_types[MAX_CHARACTER_KINDS + 1];
+
/* The integer kind to use for array indices. This will be set to the
proper value based on target information from the backend. */
int gfc_character_storage_size;
-/* Validate that the f90_type of the given gfc_typespec is valid for
- the type it represents. The f90_type represents the Fortran types
- this C kind can be used with. For example, c_int has a f90_type of
- BT_INTEGER and c_float has a f90_type of BT_REAL. Returns FAILURE
- if a mismatch occurs between ts->f90_type and ts->type; SUCCESS if
- they match. */
-
-try
-gfc_validate_c_kind (gfc_typespec *ts)
-{
- return ((ts->type == ts->f90_type) ? SUCCESS : FAILURE);
-}
-
-
-try
+gfc_try
gfc_check_any_c_kind (gfc_typespec *ts)
{
int i;
return -1;
}
+/* Return a typenode for the "standard" C type with a given name. */
+static tree
+get_typenode_from_name (const char *name)
+{
+ if (name == NULL || *name == '\0')
+ return NULL_TREE;
+
+ if (strcmp (name, "char") == 0)
+ return char_type_node;
+ if (strcmp (name, "unsigned char") == 0)
+ return unsigned_char_type_node;
+ if (strcmp (name, "signed char") == 0)
+ return signed_char_type_node;
+
+ if (strcmp (name, "short int") == 0)
+ return short_integer_type_node;
+ if (strcmp (name, "short unsigned int") == 0)
+ return short_unsigned_type_node;
+
+ if (strcmp (name, "int") == 0)
+ return integer_type_node;
+ if (strcmp (name, "unsigned int") == 0)
+ return unsigned_type_node;
+
+ if (strcmp (name, "long int") == 0)
+ return long_integer_type_node;
+ if (strcmp (name, "long unsigned int") == 0)
+ return long_unsigned_type_node;
+
+ if (strcmp (name, "long long int") == 0)
+ return long_long_integer_type_node;
+ if (strcmp (name, "long long unsigned int") == 0)
+ return long_long_unsigned_type_node;
+
+ gcc_unreachable ();
+}
+
+static int
+get_int_kind_from_name (const char *name)
+{
+ return get_int_kind_from_node (get_typenode_from_name (name));
+}
+
+
+/* Get the kind number corresponding to an integer of given size,
+ following the required return values for ISO_FORTRAN_ENV INT* constants:
+ -2 is returned if we support a kind of larger size, -1 otherwise. */
+int
+gfc_get_int_kind_from_width_isofortranenv (int size)
+{
+ int i;
+
+ /* Look for a kind with matching storage size. */
+ for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+ if (gfc_integer_kinds[i].bit_size == size)
+ return gfc_integer_kinds[i].kind;
+
+ /* Look for a kind with larger storage size. */
+ for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+ if (gfc_integer_kinds[i].bit_size > size)
+ return -2;
+
+ return -1;
+}
+
+/* Get the kind number corresponding to a real of given storage size,
+ following the required return values for ISO_FORTRAN_ENV REAL* constants:
+ -2 is returned if we support a kind of larger size, -1 otherwise. */
+int
+gfc_get_real_kind_from_width_isofortranenv (int size)
+{
+ int i;
+
+ size /= 8;
+
+ /* Look for a kind with matching storage size. */
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size)
+ return gfc_real_kinds[i].kind;
+
+ /* Look for a kind with larger storage size. */
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size)
+ return -2;
+
+ return -1;
+}
+
+
+
static int
get_int_kind_from_width (int size)
{
void init_c_interop_kinds (void)
{
int i;
- tree intmax_type_node = INT_TYPE_SIZE == LONG_LONG_TYPE_SIZE ?
- integer_type_node :
- (LONG_TYPE_SIZE == LONG_LONG_TYPE_SIZE ?
- long_integer_type_node :
- long_long_integer_type_node);
/* init all pointers in the list to NULL */
for (i = 0; i < ISOCBINDING_NUMBER; i++)
c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
}
-#define NAMED_INTCST(a,b,c) \
+#define NAMED_INTCST(a,b,c,d) \
strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
c_interop_kinds_table[a].f90_type = BT_INTEGER; \
c_interop_kinds_table[a].value = c;
void
gfc_init_kinds (void)
{
- enum machine_mode mode;
- int i_index, r_index;
+ unsigned int mode;
+ int i_index, r_index, kind;
bool saw_i4 = false, saw_i8 = false;
bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
{
int kind, bitsize;
- if (!targetm.scalar_mode_supported_p (mode))
+ if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
continue;
/* The middle end doesn't support constants larger than 2*HWI.
for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
{
- const struct real_format *fmt = REAL_MODE_FORMAT (mode);
+ const struct real_format *fmt =
+ REAL_MODE_FORMAT ((enum machine_mode) mode);
int kind;
if (fmt == NULL)
continue;
- if (!targetm.scalar_mode_supported_p (mode))
+ if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
continue;
/* Only let float/double/long double go through because the fortran
if (kind == 16)
saw_r16 = true;
- /* Careful we don't stumble a wierd internal mode. */
+ /* Careful we don't stumble a weird internal mode. */
gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
/* Or have too many modes for the allocated space. */
gcc_assert (r_index != MAX_REAL_KINDS);
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
+ the numeric 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;
}
gfc_default_logical_kind = gfc_default_integer_kind;
gfc_default_complex_kind = gfc_default_real_kind;
+ /* We only have two character kinds: ASCII and UCS-4.
+ ASCII corresponds to a 8-bit integer type, if one is available.
+ UCS-4 corresponds to a 32-bit integer type, if one is available. */
+ i_index = 0;
+ if ((kind = get_int_kind_from_width (8)) > 0)
+ {
+ gfc_character_kinds[i_index].kind = kind;
+ gfc_character_kinds[i_index].bit_size = 8;
+ gfc_character_kinds[i_index].name = "ascii";
+ i_index++;
+ }
+ if ((kind = get_int_kind_from_width (32)) > 0)
+ {
+ gfc_character_kinds[i_index].kind = kind;
+ gfc_character_kinds[i_index].bit_size = 32;
+ gfc_character_kinds[i_index].name = "iso_10646";
+ i_index++;
+ }
+
/* Choose the smallest integer kind for our default character. */
- gfc_default_character_kind = gfc_integer_kinds[0].kind;
+ gfc_default_character_kind = gfc_character_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. */
static int
validate_character (int kind)
{
- return kind == gfc_default_character_kind ? 0 : -1;
+ int i;
+
+ for (i = 0; gfc_character_kinds[i].kind; i++)
+ if (gfc_character_kinds[i].kind == kind)
+ return i;
+
+ return -1;
}
/* Validate a kind given a basic type. The return value is the same
return make_signed_type (mode_precision);
}
+tree
+gfc_build_uint_type (int size)
+{
+ if (size == CHAR_TYPE_SIZE)
+ return unsigned_char_type_node;
+ if (size == SHORT_TYPE_SIZE)
+ return short_unsigned_type_node;
+ if (size == INT_TYPE_SIZE)
+ return unsigned_type_node;
+ if (size == LONG_TYPE_SIZE)
+ return long_unsigned_type_node;
+ if (size == LONG_LONG_TYPE_SIZE)
+ return long_long_unsigned_type_node;
+
+ return make_unsigned_type (size);
+}
+
+
static tree
gfc_build_real_type (gfc_real_info *info)
{
return new_type;
}
+
#if 0
/* Return the bit size of the C "size_t". */
void
gfc_init_types (void)
{
- char name_buf[16];
+ char name_buf[18];
int index;
tree type;
unsigned n;
for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
{
type = gfc_build_int_type (&gfc_integer_kinds[index]);
+ /* Ensure integer(kind=1) doesn't have TYPE_STRING_FLAG set. */
+ if (TYPE_STRING_FLAG (type))
+ type = make_signed_type (gfc_integer_kinds[index].bit_size);
gfc_integer_types[index] = type;
- snprintf (name_buf, sizeof(name_buf), "int%d",
+ snprintf (name_buf, sizeof(name_buf), "integer(kind=%d)",
gfc_integer_kinds[index].kind);
PUSH_TYPE (name_buf, type);
}
{
type = gfc_build_logical_type (&gfc_logical_kinds[index]);
gfc_logical_types[index] = type;
- snprintf (name_buf, sizeof(name_buf), "logical%d",
+ snprintf (name_buf, sizeof(name_buf), "logical(kind=%d)",
gfc_logical_kinds[index].kind);
PUSH_TYPE (name_buf, type);
}
{
type = gfc_build_real_type (&gfc_real_kinds[index]);
gfc_real_types[index] = type;
- snprintf (name_buf, sizeof(name_buf), "real%d",
+ snprintf (name_buf, sizeof(name_buf), "real(kind=%d)",
gfc_real_kinds[index].kind);
PUSH_TYPE (name_buf, type);
type = gfc_build_complex_type (type);
gfc_complex_types[index] = type;
- snprintf (name_buf, sizeof(name_buf), "complex%d",
+ snprintf (name_buf, sizeof(name_buf), "complex(kind=%d)",
gfc_real_kinds[index].kind);
PUSH_TYPE (name_buf, type);
}
- gfc_character1_type_node = build_type_variant (unsigned_char_type_node,
- 0, 0);
- PUSH_TYPE ("char", gfc_character1_type_node);
+ for (index = 0; gfc_character_kinds[index].kind != 0; ++index)
+ {
+ type = gfc_build_uint_type (gfc_character_kinds[index].bit_size);
+ type = build_qualified_type (type, TYPE_UNQUALIFIED);
+ snprintf (name_buf, sizeof(name_buf), "character(kind=%d)",
+ gfc_character_kinds[index].kind);
+ PUSH_TYPE (name_buf, type);
+ gfc_character_types[index] = type;
+ gfc_pcharacter_types[index] = build_pointer_type (type);
+ }
+ gfc_character1_type_node = gfc_character_types[0];
PUSH_TYPE ("byte", unsigned_char_type_node);
PUSH_TYPE ("void", void_type_node);
pvoid_type_node = build_pointer_type (void_type_node);
ppvoid_type_node = build_pointer_type (pvoid_type_node);
pchar_type_node = build_pointer_type (gfc_character1_type_node);
+ pfunc_type_node
+ = build_pointer_type (build_function_type (void_type_node, NULL_TREE));
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,
int index = gfc_validate_kind (BT_LOGICAL, kind, true);
return index < 0 ? 0 : gfc_logical_types[index];
}
+
+tree
+gfc_get_char_type (int kind)
+{
+ int index = gfc_validate_kind (BT_CHARACTER, kind, true);
+ return index < 0 ? 0 : gfc_character_types[index];
+}
+
+tree
+gfc_get_pchar_type (int kind)
+{
+ int index = gfc_validate_kind (BT_CHARACTER, kind, true);
+ return index < 0 ? 0 : gfc_pcharacter_types[index];
+}
+
\f
/* Create a character type with the given kind and length. */
tree
-gfc_get_character_type_len (int kind, tree len)
+gfc_get_character_type_len_for_eltype (tree eltype, tree len)
{
tree bounds, type;
- gfc_validate_kind (BT_CHARACTER, kind, false);
-
bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
- type = build_array_type (gfc_character1_type_node, bounds);
+ type = build_array_type (eltype, bounds);
TYPE_STRING_FLAG (type) = 1;
return type;
}
+tree
+gfc_get_character_type_len (int kind, tree len)
+{
+ gfc_validate_kind (BT_CHARACTER, kind, false);
+ return gfc_get_character_type_len_for_eltype (gfc_get_char_type (kind), len);
+}
+
/* Get a type node for a character kind. */
has been resolved. This is done so we can convert C_PTR and
C_FUNPTR to simple variables that get translated to (void *). */
if (spec->f90_type == BT_VOID)
- basetype = ptr_type_node;
+ {
+ if (spec->derived
+ && spec->derived->intmod_sym_id == ISOCBINDING_PTR)
+ basetype = ptr_type_node;
+ else
+ basetype = pfunc_type_node;
+ }
else
basetype = gfc_get_int_type (spec->kind);
break;
}
break;
case BT_VOID:
- /* This is for the second arg to c_f_pointer and c_f_procpointer
- of the iso_c_binding module, to accept any ptr type. */
- basetype = ptr_type_node;
+ /* This is for the second arg to c_f_pointer and c_f_procpointer
+ of the iso_c_binding module, to accept any ptr type. */
+ basetype = ptr_type_node;
+ if (spec->f90_type == BT_VOID)
+ {
+ if (spec->derived
+ && spec->derived->intmod_sym_id == ISOCBINDING_PTR)
+ basetype = ptr_type_node;
+ else
+ basetype = pfunc_type_node;
+ }
break;
default:
gcc_unreachable ();
ARRAYS comment.
The data component points to the first element in the array. The
- offset field is the position of the origin of the array (ie element
- (0, 0 ...)). This may be outsite the bounds of the array.
+ offset field is the position of the origin of the array (i.e. element
+ (0, 0 ...)). This may be outside the bounds of the array.
An element is accessed by
data[offset + index0*stride0 + index1*stride1 + index2*stride2]
elements of the origin (2^63 on 64-bit machines). For example
integer, dimension (80000:90000, 80000:90000, 2) :: array
may not work properly on 32-bit machines because 80000*80000 >
- 2^31, so the calculation for stride02 would overflow. This may
+ 2^31, so the calculation for stride2 would overflow. This may
still work, but I haven't checked, and it relies on the overflow
doing the right thing.
/* Create an array descriptor type. */
static tree
-gfc_build_array_type (tree type, gfc_array_spec * as)
+gfc_build_array_type (tree type, gfc_array_spec * as,
+ enum gfc_array_kind akind)
{
tree lbound[GFC_MAX_DIMENSIONS];
tree ubound[GFC_MAX_DIMENSIONS];
ubound[n] = gfc_conv_array_bound (as->upper[n]);
}
- return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0);
+ if (as->type == AS_ASSUMED_SHAPE)
+ akind = GFC_ARRAY_ASSUMED_SHAPE;
+ return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0, akind);
}
\f
/* Returns the struct descriptor_dimension type. */
decl = build_decl (FIELD_DECL,
get_identifier ("stride"), gfc_array_index_type);
DECL_CONTEXT (decl) = type;
+ TREE_NO_WARNING (decl) = 1;
fieldlist = decl;
decl = build_decl (FIELD_DECL,
get_identifier ("lbound"), gfc_array_index_type);
DECL_CONTEXT (decl) = type;
+ TREE_NO_WARNING (decl) = 1;
fieldlist = chainon (fieldlist, decl);
decl = build_decl (FIELD_DECL,
get_identifier ("ubound"), gfc_array_index_type);
DECL_CONTEXT (decl) = type;
+ TREE_NO_WARNING (decl) = 1;
fieldlist = chainon (fieldlist, decl);
/* Finish off the type. */
TYPE_FIELDS (type) = fieldlist;
gfc_finish_type (type);
+ TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
gfc_desc_dim_type = type;
return type;
{
/* Fill in the stride and bound components of the type. */
if (known_stride)
- tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
+ tmp = gfc_conv_mpz_to_tree (stride, gfc_index_integer_kind);
else
tmp = NULL_TREE;
GFC_TYPE_ARRAY_STRIDE (type, n) = tmp;
if (expr->expr_type == EXPR_CONSTANT)
{
tmp = gfc_conv_mpz_to_tree (expr->value.integer,
- gfc_index_integer_kind);
+ gfc_index_integer_kind);
}
else
{
mpz_clear (stride);
mpz_clear (delta);
+ /* Represent packed arrays as multi-dimensional if they have rank >
+ 1 and with proper bounds, instead of flat arrays. This makes for
+ better debug info. */
+ if (known_offset)
+ {
+ tree gtype = etype, rtype, type_decl;
+
+ for (n = as->rank - 1; n >= 0; n--)
+ {
+ rtype = build_range_type (gfc_array_index_type,
+ GFC_TYPE_ARRAY_LBOUND (type, n),
+ GFC_TYPE_ARRAY_UBOUND (type, n));
+ gtype = build_array_type (gtype, rtype);
+ }
+ TYPE_NAME (type) = type_decl = build_decl (TYPE_DECL, NULL, gtype);
+ DECL_ORIGINAL_TYPE (type_decl) = gtype;
+ }
+
if (packed != PACKED_STATIC || !known_stride)
{
/* For dummy arrays and automatic (heap allocated) arrays we
decl = build_decl (FIELD_DECL, get_identifier ("offset"),
gfc_array_index_type);
DECL_CONTEXT (decl) = fat_type;
+ TREE_NO_WARNING (decl) = 1;
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;
+ TREE_NO_WARNING (decl) = 1;
fieldlist = chainon (fieldlist, decl);
/* Build the array type for the stride and bound components. */
decl = build_decl (FIELD_DECL, get_identifier ("dim"), arraytype);
DECL_CONTEXT (decl) = fat_type;
+ TREE_NO_WARNING (decl) = 1;
fieldlist = chainon (fieldlist, decl);
/* Finish off the type. */
TYPE_FIELDS (fat_type) = fieldlist;
gfc_finish_type (fat_type);
+ TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
gfc_array_descriptor_base[dimen - 1] = fat_type;
return fat_type;
tree
gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
- tree * ubound, int packed)
+ tree * ubound, int packed,
+ enum gfc_array_kind akind)
{
char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
- tree fat_type, base_type, arraytype, lower, upper, stride, tmp;
- const char *typename;
+ tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
+ const char *type_name;
int n;
base_type = gfc_get_array_descriptor_base (dimen);
if (tmp && TREE_CODE (tmp) == TYPE_DECL)
tmp = DECL_NAME (tmp);
if (tmp)
- typename = IDENTIFIER_POINTER (tmp);
+ type_name = IDENTIFIER_POINTER (tmp);
else
- typename = "unknown";
+ type_name = "unknown";
sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
- GFC_MAX_SYMBOL_LEN, typename);
+ GFC_MAX_SYMBOL_LEN, type_name);
TYPE_NAME (fat_type) = get_identifier (name);
GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
+ GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
/* Build an array descriptor record type. */
if (packed != 0)
/* 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, gfc_array_range_type);
+ /* We define data as an array with the correct size if possible.
+ Much better than doing pointer arithmetic. */
+ if (stride)
+ rtype = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+ int_const_binop (MINUS_EXPR, stride,
+ integer_one_node, 0));
+ else
+ rtype = gfc_array_range_type;
+ arraytype = build_array_type (etype, rtype);
arraytype = build_pointer_type (arraytype);
GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
+ /* This will generate the base declarations we need to emit debug
+ information for this type. FIXME: there must be a better way to
+ avoid divergence between compilations with and without debug
+ information. */
+ {
+ struct array_descr_info info;
+ gfc_get_array_descr_info (fat_type, &info);
+ gfc_get_array_descr_info (build_pointer_type (fat_type), &info);
+ }
+
return fat_type;
}
\f
tree type;
int byref;
+ /* Procedure Pointers inside COMMON blocks. */
+ if (sym->attr.proc_pointer && sym->attr.in_common)
+ {
+ /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
+ sym->attr.proc_pointer = 0;
+ type = build_pointer_type (gfc_get_function_type (sym));
+ sym->attr.proc_pointer = 1;
+ return type;
+ }
+
if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
return void_type_node;
if (sym->backend_decl && !sym->attr.function)
return TREE_TYPE (sym->backend_decl);
- type = gfc_typenode_for_spec (&sym->ts);
+ if (sym->ts.type == BT_CHARACTER
+ && ((sym->attr.function && sym->attr.is_bind_c)
+ || (sym->attr.result
+ && sym->ns->proc_name
+ && sym->ns->proc_name->attr.is_bind_c)))
+ type = gfc_character1_type_node;
+ else
+ type = gfc_typenode_for_spec (&sym->ts);
if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
byref = 1;
}
}
else
- {
- type = gfc_build_array_type (type, sym->as);
- }
+ {
+ enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN;
+ if (sym->attr.pointer)
+ akind = GFC_ARRAY_POINTER;
+ else if (sym->attr.allocatable)
+ akind = GFC_ARRAY_ALLOCATABLE;
+ type = gfc_build_array_type (type, sym->as, akind);
+ }
}
else
{
if (sym->attr.allocatable || sym->attr.pointer)
type = gfc_build_pointer_type (sym, type);
+ if (sym->attr.pointer)
+ GFC_POINTER_TYPE_P (type) = 1;
}
/* We currently pass all parameters by reference.
for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
{
to_cm->backend_decl = from_cm->backend_decl;
- if (!from_cm->pointer && from_cm->ts.type == BT_DERIVED)
+ if (!from_cm->attr.pointer && from_cm->ts.type == BT_DERIVED)
gfc_get_derived_type (to_cm->ts.derived);
else if (from_cm->ts.type == BT_CHARACTER)
}
+/* Build a tree node for a procedure pointer component. */
+
+tree
+gfc_get_ppc_type (gfc_component* c)
+{
+ tree t;
+ if (c->attr.function && !c->attr.dimension)
+ t = gfc_typenode_for_spec (&c->ts);
+ else
+ t = void_type_node;
+ /* TODO: Build argument list. */
+ return build_pointer_type (build_function_type (t, NULL_TREE));
+}
+
+
/* 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
/* See if it's one of the iso_c_binding derived types. */
if (derived->attr.is_iso_c == 1)
{
- derived->backend_decl = ptr_type_node;
+ if (derived->backend_decl)
+ return derived->backend_decl;
+
+ if (derived->intmod_sym_id == ISOCBINDING_PTR)
+ derived->backend_decl = ptr_type_node;
+ else
+ derived->backend_decl = pfunc_type_node;
+
+ /* Create a backend_decl for the __c_ptr_c_address field. */
+ derived->components->backend_decl =
+ gfc_add_field_to_struct (&(derived->backend_decl->type.values),
+ derived->backend_decl,
+ get_identifier (derived->components->name),
+ gfc_typenode_for_spec (
+ &(derived->components->ts)));
+
derived->ts.kind = gfc_index_integer_kind;
derived->ts.type = BT_INTEGER;
/* Set the f90_type to BT_VOID as a way to recognize something of type
BT_INTEGER that needs to fit a void * for the purpose of the
iso_c_binding derived types. */
derived->ts.f90_type = BT_VOID;
+
return derived->backend_decl;
}
/* derived->backend_decl != 0 means we saw it before, but its
components' backend_decl may have not been built. */
if (derived->backend_decl)
- {
- /* Its components' backend_decl have been built. */
- if (TYPE_FIELDS (derived->backend_decl))
- return derived->backend_decl;
- else
- typenode = derived->backend_decl;
- }
+ return derived->backend_decl;
else
{
-
/* We see this derived type first time, so build the type node. */
typenode = make_node (RECORD_TYPE);
TYPE_NAME (typenode) = get_identifier (derived->name);
if (c->ts.type != BT_DERIVED)
continue;
- if (!c->pointer || c->ts.derived->backend_decl == NULL)
+ if (!c->attr.pointer || c->ts.derived->backend_decl == NULL)
c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
if (c->ts.derived && c->ts.derived->attr.is_iso_c)
c->ts.type = c->ts.derived->ts.type;
c->ts.kind = c->ts.derived->ts.kind;
c->ts.f90_type = c->ts.derived->ts.f90_type;
+ if (c->initializer)
+ {
+ c->initializer->ts.type = c->ts.type;
+ c->initializer->ts.kind = c->ts.kind;
+ c->initializer->ts.f90_type = c->ts.f90_type;
+ c->initializer->expr_type = EXPR_NULL;
+ }
}
}
{
if (c->ts.type == BT_DERIVED)
field_type = c->ts.derived->backend_decl;
+ else if (c->attr.proc_pointer)
+ field_type = gfc_get_ppc_type (c);
else
{
if (c->ts.type == BT_CHARACTER)
/* This returns an array descriptor type. Initialization may be
required. */
- if (c->dimension)
+ if (c->attr.dimension && !c->attr.proc_pointer)
{
- if (c->pointer || c->allocatable)
+ if (c->attr.pointer || c->attr.allocatable)
{
+ enum gfc_array_kind akind;
+ if (c->attr.pointer)
+ akind = GFC_ARRAY_POINTER;
+ else
+ akind = GFC_ARRAY_ALLOCATABLE;
/* 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);
+ field_type = gfc_build_array_type (field_type, c->as, akind);
}
else
field_type = gfc_get_nodesc_array_type (field_type, c->as,
PACKED_STATIC);
}
- else if (c->pointer)
+ else if (c->attr.pointer)
field_type = build_pointer_type (field_type);
field = gfc_add_field_to_struct (&fieldlist, typenode,
get_identifier (c->name),
field_type);
+ if (c->loc.lb)
+ gfc_set_decl_location (field, &c->loc);
+ else if (derived->declared_at.lb)
+ gfc_set_decl_location (field, &derived->declared_at);
DECL_PACKED (field) |= TYPE_PACKED (typenode);
TYPE_FIELDS (typenode) = fieldlist;
gfc_finish_type (typenode);
+ gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
+ if (derived->module && derived->ns->proc_name
+ && derived->ns->proc_name->attr.flavor == FL_MODULE)
+ {
+ if (derived->ns->proc_name->backend_decl
+ && TREE_CODE (derived->ns->proc_name->backend_decl)
+ == NAMESPACE_DECL)
+ {
+ TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl;
+ DECL_CONTEXT (TYPE_STUB_DECL (typenode))
+ = derived->ns->proc_name->backend_decl;
+ }
+ }
derived->backend_decl = typenode;
- /* Add this backend_decl to all the other, equal derived types. */
- for (dt = gfc_derived_types; dt; dt = dt->next)
- copy_dt_decls_ifequal (derived, dt->derived);
+ /* Add this backend_decl to all the other, equal derived types. */
+ for (dt = gfc_derived_types; dt; dt = dt->next)
+ copy_dt_decls_ifequal (derived, dt->derived);
return derived->backend_decl;
}
if (sym->attr.dimension)
return 1;
- if (sym->ts.type == BT_CHARACTER)
+ if (sym->ts.type == BT_CHARACTER
+ && !sym->attr.is_bind_c
+ && (!sym->attr.result
+ || !sym->ns->proc_name
+ || !sym->ns->proc_name->attr.is_bind_c))
return 1;
/* Possibly return complex numbers by reference for g77 compatibility.
TYPE_FIELDS (type) = fieldlist;
gfc_finish_type (type);
+ TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
return type;
}
\f
int nstr;
int alternate_return;
- /* Make sure this symbol is a function or a subroutine. */
- gcc_assert (sym->attr.flavor == FL_PROCEDURE);
+ /* Make sure this symbol is a function, a subroutine or the main
+ program. */
+ gcc_assert (sym->attr.flavor == FL_PROCEDURE
+ || sym->attr.flavor == FL_PROGRAM);
if (sym->backend_decl)
return TREE_TYPE (sym->backend_decl);
typelist = gfc_chainon_list (typelist, gfc_array_index_type);
}
+ if (sym->result)
+ arg = sym->result;
+ else
+ arg = sym;
+
+ if (arg->ts.type == BT_CHARACTER)
+ gfc_conv_const_charlen (arg->ts.cl);
+
/* Some functions we use an extra parameter for the return value. */
if (gfc_return_by_reference (sym))
{
- if (sym->result)
- arg = sym->result;
- else
- arg = sym;
-
- if (arg->ts.type == BT_CHARACTER)
- gfc_conv_const_charlen (arg->ts.cl);
-
type = gfc_sym_type (arg);
if (arg->ts.type == BT_COMPLEX
|| arg->attr.dimension
type = gfc_typenode_for_spec (&sym->ts);
sym->ts.kind = gfc_default_real_kind;
}
+ else if (sym->result && sym->result->attr.proc_pointer)
+ /* Procedure pointer return values. */
+ {
+ if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0)
+ {
+ /* Unset proc_pointer as gfc_get_function_type
+ is called recursively. */
+ sym->result->attr.proc_pointer = 0;
+ type = build_pointer_type (gfc_get_function_type (sym->result));
+ sym->result->attr.proc_pointer = 1;
+ }
+ else
+ type = gfc_sym_type (sym->result);
+ }
else
type = gfc_sym_type (sym);
}
/* Handle TImode as a special case because it is used by some backends
- (eg. ARM) even though it is not available for normal use. */
+ (e.g. ARM) even though it is not available for normal use. */
#if HOST_BITS_PER_WIDE_INT >= 64
if (bits == TYPE_PRECISION (intTI_type_node))
return intTI_type_node;
return NULL_TREE;
}
+/* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
+ in that case. */
+
+bool
+gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
+{
+ int rank, dim;
+ bool indirect = false;
+ tree etype, ptype, field, t, base_decl;
+ tree data_off, offset_off, dim_off, dim_size, elem_size;
+ tree lower_suboff, upper_suboff, stride_suboff;
+
+ if (! GFC_DESCRIPTOR_TYPE_P (type))
+ {
+ if (! POINTER_TYPE_P (type))
+ return false;
+ type = TREE_TYPE (type);
+ if (! GFC_DESCRIPTOR_TYPE_P (type))
+ return false;
+ indirect = true;
+ }
+
+ rank = GFC_TYPE_ARRAY_RANK (type);
+ if (rank >= (int) (sizeof (info->dimen) / sizeof (info->dimen[0])))
+ return false;
+
+ etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+ gcc_assert (POINTER_TYPE_P (etype));
+ etype = TREE_TYPE (etype);
+ gcc_assert (TREE_CODE (etype) == ARRAY_TYPE);
+ etype = TREE_TYPE (etype);
+ /* Can't handle variable sized elements yet. */
+ if (int_size_in_bytes (etype) <= 0)
+ return false;
+ /* Nor non-constant lower bounds in assumed shape arrays. */
+ if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
+ {
+ for (dim = 0; dim < rank; dim++)
+ if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE
+ || TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) != INTEGER_CST)
+ return false;
+ }
+
+ memset (info, '\0', sizeof (*info));
+ info->ndimensions = rank;
+ info->element_type = etype;
+ ptype = build_pointer_type (gfc_array_index_type);
+ base_decl = GFC_TYPE_ARRAY_BASE_DECL (type, indirect);
+ if (!base_decl)
+ {
+ base_decl = build_decl (VAR_DECL, NULL_TREE,
+ indirect ? build_pointer_type (ptype) : ptype);
+ GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl;
+ }
+ info->base_decl = base_decl;
+ if (indirect)
+ base_decl = build1 (INDIRECT_REF, ptype, base_decl);
+
+ if (GFC_TYPE_ARRAY_SPAN (type))
+ elem_size = GFC_TYPE_ARRAY_SPAN (type);
+ else
+ elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
+ field = TYPE_FIELDS (TYPE_MAIN_VARIANT (type));
+ data_off = byte_position (field);
+ field = TREE_CHAIN (field);
+ offset_off = byte_position (field);
+ field = TREE_CHAIN (field);
+ field = TREE_CHAIN (field);
+ dim_off = byte_position (field);
+ dim_size = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (field)));
+ field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (field)));
+ stride_suboff = byte_position (field);
+ field = TREE_CHAIN (field);
+ lower_suboff = byte_position (field);
+ field = TREE_CHAIN (field);
+ upper_suboff = byte_position (field);
+
+ t = base_decl;
+ if (!integer_zerop (data_off))
+ t = build2 (POINTER_PLUS_EXPR, ptype, t, data_off);
+ t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
+ info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
+ if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
+ info->allocated = build2 (NE_EXPR, boolean_type_node,
+ info->data_location, null_pointer_node);
+ else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER)
+ info->associated = build2 (NE_EXPR, boolean_type_node,
+ info->data_location, null_pointer_node);
+
+ for (dim = 0; dim < rank; dim++)
+ {
+ t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
+ size_binop (PLUS_EXPR, dim_off, lower_suboff));
+ t = build1 (INDIRECT_REF, gfc_array_index_type, t);
+ info->dimen[dim].lower_bound = t;
+ t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
+ size_binop (PLUS_EXPR, dim_off, upper_suboff));
+ t = build1 (INDIRECT_REF, gfc_array_index_type, t);
+ info->dimen[dim].upper_bound = t;
+ if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE)
+ {
+ /* Assumed shape arrays have known lower bounds. */
+ info->dimen[dim].upper_bound
+ = build2 (MINUS_EXPR, gfc_array_index_type,
+ info->dimen[dim].upper_bound,
+ info->dimen[dim].lower_bound);
+ info->dimen[dim].lower_bound
+ = fold_convert (gfc_array_index_type,
+ GFC_TYPE_ARRAY_LBOUND (type, dim));
+ info->dimen[dim].upper_bound
+ = build2 (PLUS_EXPR, gfc_array_index_type,
+ info->dimen[dim].lower_bound,
+ info->dimen[dim].upper_bound);
+ }
+ t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
+ size_binop (PLUS_EXPR, dim_off, stride_suboff));
+ t = build1 (INDIRECT_REF, gfc_array_index_type, t);
+ t = build2 (MULT_EXPR, gfc_array_index_type, t, elem_size);
+ info->dimen[dim].stride = t;
+ dim_off = size_binop (PLUS_EXPR, dim_off, dim_size);
+ }
+
+ return true;
+}
+
#include "gt-fortran-trans-types.h"