/* Backend support for Fortran 95 basic types and derived types.
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
- 2010, 2011
- Free Software Foundation, Inc.
+ Copyright (C) 2002-2015 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#include "config.h"
#include "system.h"
#include "coretypes.h"
+#include "tm.h" /* For INTMAX_TYPE, INT8_TYPE, INT16_TYPE, INT32_TYPE,
+ INT64_TYPE, INT_LEAST8_TYPE, INT_LEAST16_TYPE,
+ INT_LEAST32_TYPE, INT_LEAST64_TYPE, INT_FAST8_TYPE,
+ INT_FAST16_TYPE, INT_FAST32_TYPE, INT_FAST64_TYPE,
+ BOOL_TYPE_SIZE, BITS_PER_UNIT, POINTER_SIZE,
+ INT_TYPE_SIZE, CHAR_TYPE_SIZE, SHORT_TYPE_SIZE,
+ LONG_TYPE_SIZE, LONG_LONG_TYPE_SIZE,
+ FLOAT_TYPE_SIZE, DOUBLE_TYPE_SIZE and
+ LONG_DOUBLE_TYPE_SIZE. */
+#include "hash-set.h"
+#include "machmode.h"
+#include "vec.h"
+#include "double-int.h"
+#include "input.h"
+#include "alias.h"
+#include "symtab.h"
+#include "wide-int.h"
+#include "inchash.h"
+#include "real.h"
#include "tree.h"
+#include "fold-const.h"
+#include "stor-layout.h"
+#include "stringpool.h"
#include "langhooks.h" /* For iso-c-bindings.def. */
#include "target.h"
#include "ggc.h"
+#include "gfortran.h"
#include "diagnostic-core.h" /* For fatal_error. */
#include "toplev.h" /* For rest_of_decl_compilation. */
-#include "gfortran.h"
#include "trans.h"
#include "trans-types.h"
#include "trans-const.h"
static GTY(()) tree gfc_desc_dim_type;
static GTY(()) tree gfc_max_array_element_size;
-static GTY(()) tree gfc_array_descriptor_base[2 * GFC_MAX_DIMENSIONS];
+static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)];
+static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)];
/* 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. */
int gfc_default_logical_kind;
int gfc_default_complex_kind;
int gfc_c_int_kind;
+int gfc_atomic_int_kind;
+int gfc_atomic_logical_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;
+int gfc_intio_kind;
/* The integer kind used to store character lengths. */
int gfc_charlen_int_kind;
int gfc_character_storage_size;
-gfc_try
+bool
gfc_check_any_c_kind (gfc_typespec *ts)
{
int i;
-
+
for (i = 0; i < ISOCBINDING_NUMBER; i++)
{
/* Check for any C interoperable kind for the given type/kind in ts.
Fortran kind being used exists in at least some form for C. */
if (c_interop_kinds_table[i].f90_type == ts->type &&
c_interop_kinds_table[i].value == ts->kind)
- return SUCCESS;
+ return true;
}
- return FAILURE;
+ return false;
}
/* Generate the CInteropKind_t objects for the C interoperable
kinds. */
-static
-void init_c_interop_kinds (void)
+void
+gfc_init_c_interop_kinds (void)
{
int i;
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;
-#define NAMED_REALCST(a,b,c) \
+#define NAMED_REALCST(a,b,c,d) \
strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
c_interop_kinds_table[a].f90_type = BT_REAL; \
c_interop_kinds_table[a].value = c;
-#define NAMED_CMPXCST(a,b,c) \
+#define NAMED_CMPXCST(a,b,c,d) \
strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
c_interop_kinds_table[a].value = c;
strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
c_interop_kinds_table[a].f90_type = BT_DERIVED; \
c_interop_kinds_table[a].value = c;
-#define PROCEDURE(a,b) \
+#define NAMED_FUNCTION(a,b,c,d) \
strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
- c_interop_kinds_table[a].value = 0;
-#include "iso-c-binding.def"
-#define NAMED_FUNCTION(a,b,c,d) \
+ c_interop_kinds_table[a].value = c;
+#define NAMED_SUBROUTINE(a,b,c,d) \
strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
c_interop_kinds_table[a].value = c;
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;
+ bool saw_r4 = false, saw_r8 = false, saw_r10 = false, saw_r16 = false;
for (i_index = 0, mode = MIN_MODE_INT; mode <= MAX_MODE_INT; mode++)
{
int kind, bitsize;
- if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
+ if (!targetm.scalar_mode_supported_p ((machine_mode) mode))
continue;
/* The middle end doesn't support constants larger than 2*HWI.
Perhaps the target hook shouldn't have accepted these either,
but just to be safe... */
- bitsize = GET_MODE_BITSIZE (mode);
+ bitsize = GET_MODE_BITSIZE ((machine_mode) mode);
if (bitsize > 2*HOST_BITS_PER_WIDE_INT)
continue;
i_index += 1;
}
- /* Set the kind used to match GFC_INT_IO in libgfortran. This is
+ /* Set the kind used to match GFC_INT_IO in libgfortran. This is
used for large file access. */
if (saw_i8)
else
gfc_intio_kind = 4;
- /* If we do not at least have kind = 4, everything is pointless. */
- gcc_assert(saw_i4);
+ /* 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 ((enum machine_mode) mode);
+ REAL_MODE_FORMAT ((machine_mode) mode);
int kind;
if (fmt == NULL)
continue;
- if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
+ if (!targetm.scalar_mode_supported_p ((machine_mode) mode))
continue;
/* Only let float, double, long double and __float128 go through.
Runtime support for others is not provided, so they would be
useless. */
+ if (!targetm.libgcc_floating_mode_supported_p ((machine_mode)
+ mode))
+ continue;
if (mode != TYPE_MODE (float_type_node)
&& (mode != TYPE_MODE (double_type_node))
&& (mode != TYPE_MODE (long_double_type_node))
-#if defined(LIBGCC2_HAS_TF_MODE) && defined(ENABLE_LIBQUADMATH_SUPPORT)
+#if defined(HAVE_TFmode) && defined(ENABLE_LIBQUADMATH_SUPPORT)
&& (mode != TFmode)
#endif
)
saw_r4 = true;
if (kind == 8)
saw_r8 = true;
+ if (kind == 10)
+ saw_r10 = true;
if (kind == 16)
saw_r16 = true;
r_index += 1;
}
- /* Choose the default integer kind. We choose 4 unless the user
- directs us otherwise. */
- if (gfc_option.flag_default_integer)
+ /* Choose the default integer kind. We choose 4 unless the user directs us
+ otherwise. Even if the user specified that the default integer kind is 8,
+ the numeric storage size is not 64 bits. In this case, a warning will be
+ issued when NUMERIC_STORAGE_SIZE is used. Set NUMERIC_STORAGE_SIZE to 32. */
+
+ gfc_numeric_storage_size = 4 * 8;
+
+ if (flag_default_integer)
{
if (!saw_i8)
- fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
+ gfc_fatal_error ("INTEGER(KIND=8) is 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 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;
+ }
+ else if (flag_integer4_kind == 8)
+ {
+ if (!saw_i8)
+ gfc_fatal_error ("INTEGER(KIND=8) is not available for "
+ "%<-finteger-4-integer-8%> option");
+
+ gfc_default_integer_kind = 8;
}
else if (saw_i4)
{
gfc_default_integer_kind = 4;
- gfc_numeric_storage_size = 4 * 8;
}
else
{
}
/* Choose the default real kind. Again, we choose 4 when possible. */
- if (gfc_option.flag_default_real)
+ if (flag_default_real)
{
if (!saw_r8)
- fatal_error ("real kind=8 not available for -fdefault-real-8 option");
+ gfc_fatal_error ("REAL(KIND=8) is not available for "
+ "%<-fdefault-real-8%> option");
+
gfc_default_real_kind = 8;
}
+ else if (flag_real4_kind == 8)
+ {
+ if (!saw_r8)
+ gfc_fatal_error ("REAL(KIND=8) is not available for %<-freal-4-real-8%> "
+ "option");
+
+ gfc_default_real_kind = 8;
+ }
+ else if (flag_real4_kind == 10)
+ {
+ if (!saw_r10)
+ gfc_fatal_error ("REAL(KIND=10) is not available for "
+ "%<-freal-4-real-10%> option");
+
+ gfc_default_real_kind = 10;
+ }
+ else if (flag_real4_kind == 16)
+ {
+ if (!saw_r16)
+ gfc_fatal_error ("REAL(KIND=16) is not available for "
+ "%<-freal-4-real-16%> option");
+
+ gfc_default_real_kind = 16;
+ }
else if (saw_r4)
gfc_default_real_kind = 4;
else
gfc_default_real_kind = gfc_real_kinds[0].kind;
- /* Choose the default double kind. If -fdefault-real and -fdefault-double
+ /* 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 (flag_default_double && !flag_default_real)
+ gfc_fatal_error ("Use of %<-fdefault-double-8%> requires "
+ "%<-fdefault-real-8%>");
- if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8)
+ if (flag_default_real && flag_default_double && saw_r8)
gfc_default_double_kind = 8;
- else if (gfc_option.flag_default_real && saw_r16)
+ else if (flag_default_real && saw_r16)
gfc_default_double_kind = 16;
+ else if (flag_real8_kind == 4)
+ {
+ if (!saw_r4)
+ gfc_fatal_error ("REAL(KIND=4) is not available for "
+ "%<-freal-8-real-4%> option");
+
+ gfc_default_double_kind = 4;
+ }
+ else if (flag_real8_kind == 10 )
+ {
+ if (!saw_r10)
+ gfc_fatal_error ("REAL(KIND=10) is not available for "
+ "%<-freal-8-real-10%> option");
+
+ gfc_default_double_kind = 10;
+ }
+ else if (flag_real8_kind == 16 )
+ {
+ if (!saw_r16)
+ gfc_fatal_error ("REAL(KIND=10) is not available for "
+ "%<-freal-8-real-16%> option");
+
+ gfc_default_double_kind = 16;
+ }
else if (saw_r4 && saw_r8)
gfc_default_double_kind = 8;
else
/* 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. */
+ 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_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. */
- gfc_index_integer_kind = POINTER_SIZE / 8;
+ gfc_index_integer_kind = get_int_kind_from_name (PTRDIFF_TYPE);
+
/* Pick a kind the same size as the C "int" type. */
gfc_c_int_kind = INT_TYPE_SIZE / 8;
- /* initialize the C interoperable kinds */
- init_c_interop_kinds();
+ /* Choose atomic kinds to match C's int. */
+ gfc_atomic_int_kind = gfc_c_int_kind;
+ gfc_atomic_logical_kind = gfc_c_int_kind;
}
+
/* Make sure that a valid kind is present. Returns an index into the
associated kinds array, -1 if the kind is not present. */
}
-#if 0
-/* Return the bit size of the C "size_t". */
-
-static unsigned int
-c_size_t_size (void)
-{
-#ifdef SIZE_TYPE
- if (strcmp (SIZE_TYPE, "unsigned int") == 0)
- return INT_TYPE_SIZE;
- if (strcmp (SIZE_TYPE, "long unsigned int") == 0)
- return LONG_TYPE_SIZE;
- if (strcmp (SIZE_TYPE, "short unsigned int") == 0)
- return SHORT_TYPE_SIZE;
- gcc_unreachable ();
-#else
- return LONG_TYPE_SIZE;
-#endif
-}
-#endif
-
/* Create the backend type nodes. We map them to their
equivalent C type, at least for now. We also give
names to the types here, and we push them in the
int index;
tree type;
unsigned n;
- unsigned HOST_WIDE_INT hi;
- unsigned HOST_WIDE_INT lo;
/* Create and name the types. */
#define PUSH_TYPE(name, node) \
descriptor. */
n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;
- lo = ~ (unsigned HOST_WIDE_INT) 0;
- if (n > HOST_BITS_PER_WIDE_INT)
- hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);
- else
- hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;
gfc_max_array_element_size
- = build_int_cst_wide (long_unsigned_type_node, lo, hi);
+ = wide_int_to_tree (size_type_node,
+ wi::mask (n, UNSIGNED,
+ TYPE_PRECISION (size_type_node)));
boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);
boolean_true_node = build_int_cst (boolean_type_node, 1);
break;
case BT_CHARACTER:
-#if 0
- if (spec->deferred)
- basetype = gfc_get_character_type (spec->kind, NULL);
- else
-#endif
- basetype = gfc_get_character_type (spec->kind, spec->u.cl);
+ basetype = gfc_get_character_type (spec->kind, spec->u.cl);
+ break;
+
+ case BT_HOLLERITH:
+ /* Since this cannot be used, return a length one character. */
+ basetype = gfc_get_character_type_len (gfc_default_character_kind,
+ gfc_index_one_node);
break;
case BT_DERIVED:
case BT_CLASS:
basetype = gfc_get_derived_type (spec->u.derived);
+ if (spec->type == BT_CLASS)
+ GFC_CLASS_TYPE_P (basetype) = 1;
+
/* If we're dealing with either C_PTR or C_FUNPTR, we modified the
type and kind to fit a (void *) and the basetype returned was a
ptr_type_node. We need to pass up this new information to the
symbol that was declared of type C_PTR or C_FUNPTR. */
- if (spec->u.derived->attr.is_iso_c)
+ if (spec->u.derived->ts.f90_type == BT_VOID)
{
- spec->type = spec->u.derived->ts.type;
- spec->kind = spec->u.derived->ts.kind;
- spec->f90_type = spec->u.derived->ts.f90_type;
+ spec->type = BT_INTEGER;
+ spec->kind = gfc_index_integer_kind;
+ spec->f90_type = BT_VOID;
}
break;
case BT_VOID:
+ case BT_ASSUMED:
/* 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;
return NULL_TREE;
}
\f
+/* Return the type of an element of the array. Note that scalar coarrays
+ are special. In particular, for GFC_ARRAY_TYPE_P, the original argument
+ (with POINTER_TYPE stripped) is returned. */
+
tree
gfc_get_element_type (tree type)
{
{
if (TREE_CODE (type) == POINTER_TYPE)
type = TREE_TYPE (type);
- gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
- element = TREE_TYPE (type);
+ if (GFC_TYPE_ARRAY_RANK (type) == 0)
+ {
+ gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0);
+ element = type;
+ }
+ else
+ {
+ gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
+ element = TREE_TYPE (type);
+ }
}
else
{
gcc_assert (TREE_CODE (element) == POINTER_TYPE);
element = TREE_TYPE (element);
- gcc_assert (TREE_CODE (element) == ARRAY_TYPE);
- element = TREE_TYPE (element);
+ /* For arrays, which are not scalar coarrays. */
+ if (TREE_CODE (element) == ARRAY_TYPE && !TYPE_STRING_FLAG (element))
+ element = TREE_TYPE (element);
}
return element;
int
gfc_is_nodesc_array (gfc_symbol * sym)
{
- gcc_assert (sym->attr.dimension);
+ symbol_attribute *array_attr;
+ gfc_array_spec *as;
+ bool is_classarray = IS_CLASS_ARRAY (sym);
+
+ array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
+ as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
+
+ gcc_assert (array_attr->dimension || array_attr->codimension);
/* We only want local arrays. */
- if (sym->attr.pointer || sym->attr.allocatable)
+ if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
+ || array_attr->allocatable)
return 0;
/* We want a descriptor for associate-name arrays that do not have an
- explicitely known shape already. */
- if (sym->assoc && sym->as->type != AS_EXPLICIT)
+ explicitly known shape already. */
+ if (sym->assoc && as->type != AS_EXPLICIT)
return 0;
+ /* The dummy is stored in sym and not in the component. */
if (sym->attr.dummy)
- return sym->as->type != AS_ASSUMED_SHAPE;
+ return as->type != AS_ASSUMED_SHAPE
+ && as->type != AS_ASSUMED_RANK;
if (sym->attr.result || sym->attr.function)
return 0;
- gcc_assert (sym->as->type == AS_EXPLICIT || sym->as->cp_was_assumed);
+ gcc_assert (as->type == AS_EXPLICIT || as->cp_was_assumed);
return 1;
}
{
tree lbound[GFC_MAX_DIMENSIONS];
tree ubound[GFC_MAX_DIMENSIONS];
- int n;
+ int n, corank;
+
+ /* Assumed-shape arrays do not have codimension information stored in the
+ descriptor. */
+ corank = as->corank;
+ if (as->type == AS_ASSUMED_SHAPE ||
+ (as->type == AS_ASSUMED_RANK && akind == GFC_ARRAY_ALLOCATABLE))
+ corank = 0;
+
+ if (as->type == AS_ASSUMED_RANK)
+ for (n = 0; n < GFC_MAX_DIMENSIONS; n++)
+ {
+ lbound[n] = NULL_TREE;
+ ubound[n] = NULL_TREE;
+ }
for (n = 0; n < as->rank; n++)
{
ubound[n] = gfc_conv_array_bound (as->upper[n]);
}
+ for (n = as->rank; n < as->rank + corank; n++)
+ {
+ if (as->type != AS_DEFERRED && as->lower[n] == NULL)
+ lbound[n] = gfc_index_one_node;
+ else
+ lbound[n] = gfc_conv_array_bound (as->lower[n]);
+
+ if (n < as->rank + corank - 1)
+ ubound[n] = gfc_conv_array_bound (as->upper[n]);
+ }
+
if (as->type == AS_ASSUMED_SHAPE)
akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
: GFC_ARRAY_ASSUMED_SHAPE;
- return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound,
+ else if (as->type == AS_ASSUMED_RANK)
+ akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
+ : GFC_ARRAY_ASSUMED_RANK;
+ return gfc_get_array_type_bounds (type, as->rank == -1
+ ? GFC_MAX_DIMENSIONS : as->rank,
+ corank, lbound,
ubound, 0, akind, restricted);
}
\f
unknown cases abort. */
tree
-gfc_get_dtype (tree type)
+gfc_get_dtype_rank_type (int rank, tree etype)
{
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_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))
{
n = BT_CHARACTER;
break;
+ case POINTER_TYPE:
+ n = BT_ASSUMED;
+ break;
+
default:
/* TODO: Don't do dtype for temporary descriptorless arrays. */
/* We can strange array types for temporary arrays. */
if (size && INTEGER_CST_P (size))
{
if (tree_int_cst_lt (gfc_max_array_element_size, size))
- internal_error ("Array element size too big");
+ gfc_fatal_error ("Array element size too big at %C");
i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
}
/* TODO: Check this is actually true, particularly when repacking
assumed size parameters. */
+ return dtype;
+}
+
+
+tree
+gfc_get_dtype (tree type)
+{
+ tree dtype;
+ tree etype;
+ int rank;
+
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (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);
+ dtype = gfc_get_dtype_rank_type (rank, etype);
+
GFC_TYPE_ARRAY_DTYPE (type) = dtype;
return dtype;
}
/* We don't use build_array_type because this does not include include
lang-specific information (i.e. the bounds of the array) when checking
for duplicates. */
- type = make_node (ARRAY_TYPE);
+ if (as->rank)
+ type = make_node (ARRAY_TYPE);
+ else
+ type = build_variant_type_copy (etype);
GFC_ARRAY_TYPE_P (type) = 1;
- TYPE_LANG_SPECIFIC (type)
- = ggc_alloc_cleared_lang_type (sizeof (struct lang_type));
+ TYPE_LANG_SPECIFIC (type) = ggc_cleared_alloc<struct lang_type> ();
known_stride = (packed != PACKED_NO);
known_offset = 1;
if (packed == PACKED_NO || packed == PACKED_PARTIAL)
known_stride = 0;
}
+ for (n = as->rank; n < as->rank + as->corank; n++)
+ {
+ expr = as->lower[n];
+ if (expr->expr_type == EXPR_CONSTANT)
+ tmp = gfc_conv_mpz_to_tree (expr->value.integer,
+ gfc_index_integer_kind);
+ else
+ tmp = NULL_TREE;
+ GFC_TYPE_ARRAY_LBOUND (type, n) = tmp;
+
+ expr = as->upper[n];
+ if (expr && expr->expr_type == EXPR_CONSTANT)
+ tmp = gfc_conv_mpz_to_tree (expr->value.integer,
+ gfc_index_integer_kind);
+ else
+ tmp = NULL_TREE;
+ if (n < as->rank + as->corank - 1)
+ GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
+ }
if (known_offset)
{
GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
GFC_TYPE_ARRAY_RANK (type) = as->rank;
+ GFC_TYPE_ARRAY_CORANK (type) = as->corank;
GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
NULL_TREE);
build_qualified_type (GFC_TYPE_ARRAY_DATAPTR_TYPE (type),
TYPE_QUAL_RESTRICT);
+ if (as->rank == 0)
+ {
+ if (packed != PACKED_STATIC || flag_coarray == GFC_FCOARRAY_LIB)
+ {
+ type = build_pointer_type (type);
+
+ if (restricted)
+ type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
+
+ GFC_ARRAY_TYPE_P (type) = 1;
+ TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
+ }
+
+ return type;
+ }
+
if (known_stride)
{
mpz_sub_ui (stride, stride, 1);
DECL_ORIGINAL_TYPE (type_decl) = gtype;
}
- if (packed != PACKED_STATIC || !known_stride)
+ if (packed != PACKED_STATIC || !known_stride
+ || (as->corank && flag_coarray == GFC_FCOARRAY_LIB))
{
/* For dummy arrays and automatic (heap allocated) arrays we
want a pointer to the array. */
return type;
}
+
/* Return or create the base type for an array descriptor. */
static tree
-gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
+gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
+ enum gfc_array_kind akind)
{
tree fat_type, decl, arraytype, *chain = NULL;
char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
- int idx = 2 * (codimen + dimen - 1) + restricted;
+ int idx;
- gcc_assert (dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS);
- if (gfc_array_descriptor_base[idx])
+ /* Assumed-rank array. */
+ if (dimen == -1)
+ dimen = GFC_MAX_DIMENSIONS;
+
+ idx = 2 * (codimen + dimen) + restricted;
+
+ gcc_assert (codimen + dimen >= 0 && codimen + dimen <= GFC_MAX_DIMENSIONS);
+
+ if (flag_coarray == GFC_FCOARRAY_LIB && codimen)
+ {
+ if (gfc_array_descriptor_base_caf[idx])
+ return gfc_array_descriptor_base_caf[idx];
+ }
+ else if (gfc_array_descriptor_base[idx])
return gfc_array_descriptor_base[idx];
/* Build the type node. */
TREE_NO_WARNING (decl) = 1;
/* 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[codimen + dimen - 1]));
+ if (dimen + codimen > 0)
+ {
+ arraytype =
+ build_array_type (gfc_get_desc_dim_type (),
+ build_range_type (gfc_array_index_type,
+ gfc_index_zero_node,
+ gfc_rank_cst[codimen + dimen - 1]));
- decl = gfc_add_field_to_struct_1 (fat_type,
- get_identifier ("dim"),
- arraytype, &chain);
- TREE_NO_WARNING (decl) = 1;
+ decl = gfc_add_field_to_struct_1 (fat_type, get_identifier ("dim"),
+ arraytype, &chain);
+ TREE_NO_WARNING (decl) = 1;
+ }
+
+ if (flag_coarray == GFC_FCOARRAY_LIB && codimen
+ && akind == GFC_ARRAY_ALLOCATABLE)
+ {
+ decl = gfc_add_field_to_struct_1 (fat_type,
+ get_identifier ("token"),
+ prvoid_type_node, &chain);
+ TREE_NO_WARNING (decl) = 1;
+ }
/* Finish off the type. */
gfc_finish_type (fat_type);
TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
- gfc_array_descriptor_base[idx] = fat_type;
+ if (flag_coarray == GFC_FCOARRAY_LIB && codimen
+ && akind == GFC_ARRAY_ALLOCATABLE)
+ gfc_array_descriptor_base_caf[idx] = fat_type;
+ else
+ gfc_array_descriptor_base[idx] = fat_type;
+
return fat_type;
}
+
/* Build an array (descriptor) type with given bounds. */
tree
const char *type_name;
int n;
- base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted);
+ base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted, akind);
fat_type = build_distinct_type_copy (base_type);
/* Make sure that nontarget and target array type have the same canonical
type (and same stub decl for debug info). */
- base_type = gfc_get_array_descriptor_base (dimen, codimen, false);
+ base_type = gfc_get_array_descriptor_base (dimen, codimen, false, akind);
TYPE_CANONICAL (fat_type) = base_type;
TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
TYPE_NAMELESS (fat_type) = 1;
GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
- TYPE_LANG_SPECIFIC (fat_type)
- = ggc_alloc_cleared_lang_type (sizeof (struct lang_type));
+ TYPE_LANG_SPECIFIC (fat_type) = ggc_cleared_alloc<struct lang_type> ();
GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
+ GFC_TYPE_ARRAY_CORANK (fat_type) = codimen;
GFC_TYPE_ARRAY_DTYPE (fat_type) = NULL_TREE;
GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
stride = gfc_index_one_node;
else
stride = NULL_TREE;
- for (n = 0; n < dimen; n++)
+ for (n = 0; n < dimen + codimen; n++)
{
- GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
+ if (n < dimen)
+ GFC_TYPE_ARRAY_STRIDE (fat_type, n) = stride;
if (lbound)
lower = lbound[n];
lower = NULL_TREE;
}
+ if (codimen && n == dimen + codimen - 1)
+ break;
+
upper = ubound[n];
if (upper != NULL_TREE)
{
upper = NULL_TREE;
}
+ if (n >= dimen)
+ continue;
+
if (upper != NULL_TREE && lower != NULL_TREE && stride != NULL_TREE)
{
tmp = fold_build2_loc (input_location, MINUS_EXPR,
/* TODO: known offsets for descriptors. */
GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
+ if (dimen == 0)
+ {
+ arraytype = build_pointer_type (etype);
+ if (restricted)
+ arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
+
+ GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
+ return fat_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));
+ build_int_cst (TREE_TYPE (stride), 1)));
else
rtype = gfc_array_range_type;
arraytype = build_array_type (etype, rtype);
{
tree ret = t;
- /* If the type isn't layed out yet, don't copy it. If something
+ /* If the type isn't laid out yet, don't copy it. If something
needs it for real it should wait until the type got finished. */
if (!TYPE_SIZE (t))
return t;
if (!TYPE_LANG_SPECIFIC (t))
- TYPE_LANG_SPECIFIC (t)
- = ggc_alloc_cleared_lang_type (sizeof (struct lang_type));
+ TYPE_LANG_SPECIFIC (t) = ggc_cleared_alloc<struct lang_type> ();
/* If we're dealing with this very node already further up
the call chain (recursion via pointers and struct members)
we haven't yet determined if we really need a new type node.
if (dataptr_type != GFC_TYPE_ARRAY_DATAPTR_TYPE (t))
{
TYPE_LANG_SPECIFIC (ret)
- = ggc_alloc_cleared_lang_type (sizeof (struct
- lang_type));
+ = ggc_cleared_alloc<struct lang_type> ();
*TYPE_LANG_SPECIFIC (ret) = *TYPE_LANG_SPECIFIC (t);
GFC_TYPE_ARRAY_DATAPTR_TYPE (ret) = dataptr_type;
}
&& ((sym->attr.function && sym->attr.is_bind_c)
|| (sym->attr.result
&& sym->ns->proc_name
- && sym->ns->proc_name->attr.is_bind_c)))
+ && sym->ns->proc_name->attr.is_bind_c)
+ || (sym->ts.deferred && (!sym->ts.u.cl
+ || !sym->ts.u.cl->backend_decl))))
type = gfc_character1_type_node;
else
type = gfc_typenode_for_spec (&sym->ts);
if (!restricted)
type = gfc_nonrestricted_type (type);
- if (sym->attr.dimension)
+ if (sym->attr.dimension || sym->attr.codimension)
{
if (gfc_is_nodesc_array (sym))
{
restricted);
byref = 0;
}
-
- if (sym->attr.cray_pointee)
- GFC_POINTER_TYPE_P (type) = 1;
}
else
{
if (sym->attr.allocatable || sym->attr.pointer
|| gfc_is_associate_pointer (sym))
type = gfc_build_pointer_type (sym, type);
- if (sym->attr.pointer || sym->attr.cray_pointee)
- GFC_POINTER_TYPE_P (type) = 1;
}
/* We currently pass all parameters by reference.
{
/* We must use pointer types for potentially absent variables. The
optimizers assume a reference type argument is never NULL. */
- if (sym->attr.optional || sym->ns->proc_name->attr.entry_master)
+ if (sym->attr.optional
+ || (sym->ns->proc_name && sym->ns->proc_name->attr.entry_master))
type = build_pointer_type (type);
else
{
int
gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
- bool from_gsym)
+ bool from_gsym)
{
gfc_component *to_cm;
gfc_component *from_cm;
+ if (from == to)
+ return 1;
+
if (from->backend_decl == NULL
|| !gfc_compare_derived_types (from, to))
return 0;
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
+ 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)
{
tree canonical = NULL_TREE;
tree *chain = NULL;
bool got_canonical = false;
+ bool unlimited_entity = false;
gfc_component *c;
gfc_dt_list *dt;
gfc_namespace *ns;
- gfc_gsymbol *gsym;
- gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
+ if (derived->attr.unlimited_polymorphic
+ || (flag_coarray == GFC_FCOARRAY_LIB
+ && derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE))
+ return ptr_type_node;
+
+ if (derived && derived->attr.flavor == FL_PROCEDURE
+ && derived->attr.generic)
+ derived = gfc_find_dt_in_generic (derived);
/* See if it's one of the iso_c_binding derived types. */
- if (derived->attr.is_iso_c == 1)
+ if (derived->attr.is_iso_c == 1 || derived->ts.f90_type == BT_VOID)
{
if (derived->backend_decl)
return derived->backend_decl;
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;
}
-/* If use associated, use the module type for this one. */
- if (gfc_option.flag_whole_file
- && derived->backend_decl == NULL
- && derived->attr.use_assoc
- && derived->module)
- {
- gsym = gfc_find_gsymbol (gfc_gsym_root, derived->module);
- if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
- {
- gfc_symbol *s;
- s = NULL;
- gfc_find_symbol (derived->name, gsym->ns, 0, &s);
- if (s)
- {
- if (!s->backend_decl)
- s->backend_decl = gfc_get_derived_type (s);
- gfc_copy_dt_decls_ifequal (s, derived, true);
- goto copy_derived_types;
- }
- }
- }
+ /* If use associated, use the module type for this one. */
+ if (derived->backend_decl == NULL
+ && derived->attr.use_assoc
+ && derived->module
+ && gfc_get_module_backend_decl (derived))
+ goto copy_derived_types;
- /* If a whole file compilation, the derived types from an earlier
- namespace can be used as the the canonical type. */
- if (gfc_option.flag_whole_file
- && derived->backend_decl == NULL
- && !derived->attr.use_assoc
- && gfc_global_ns_list)
+ /* The derived types from an earlier namespace can be used as the
+ canonical type. */
+ if (derived->backend_decl == NULL && !derived->attr.use_assoc
+ && gfc_global_ns_list)
{
for (ns = gfc_global_ns_list;
ns->translated && !got_canonical;
/* Its components' backend_decl have been built or we are
seeing recursion through the formal arglist of a procedure
pointer component. */
- if (TYPE_FIELDS (derived->backend_decl)
- || derived->attr.proc_pointer_comp)
+ if (TYPE_FIELDS (derived->backend_decl))
return derived->backend_decl;
+ else if (derived->attr.abstract
+ && derived->attr.proc_pointer_comp)
+ {
+ /* If an abstract derived type with procedure pointer
+ components has no other type of component, return the
+ backend_decl. Otherwise build the components if any of the
+ non-procedure pointer components have no backend_decl. */
+ for (c = derived->components; c; c = c->next)
+ {
+ if (!c->attr.proc_pointer && c->backend_decl == NULL)
+ break;
+ else if (c->next == NULL)
+ return derived->backend_decl;
+ }
+ typenode = derived->backend_decl;
+ }
else
typenode = derived->backend_decl;
}
/* We see this derived type first time, so build the type node. */
typenode = make_node (RECORD_TYPE);
TYPE_NAME (typenode) = get_identifier (derived->name);
- TYPE_PACKED (typenode) = gfc_option.flag_pack_derived;
+ TYPE_PACKED (typenode) = flag_pack_derived;
derived->backend_decl = typenode;
}
+ if (derived->components
+ && derived->components->ts.type == BT_DERIVED
+ && strcmp (derived->components->name, "_data") == 0
+ && derived->components->ts.u.derived->attr.unlimited_polymorphic)
+ unlimited_entity = true;
+
/* 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
|| c->ts.u.derived->backend_decl == NULL)
c->ts.u.derived->backend_decl = gfc_get_derived_type (c->ts.u.derived);
- if (c->ts.u.derived && c->ts.u.derived->attr.is_iso_c)
+ if (c->ts.u.derived->attr.is_iso_c)
{
/* Need to copy the modified ts from the derived type. The
typespec was modified because C_PTR/C_FUNPTR are translated
field_type = c->ts.u.derived->backend_decl;
else
{
- if (c->ts.type == BT_CHARACTER)
+ if (c->ts.type == BT_CHARACTER && !c->ts.deferred)
{
/* Evaluate the string length. */
gfc_conv_const_charlen (c->ts.u.cl);
gcc_assert (c->ts.u.cl->backend_decl);
}
+ else if (c->ts.type == BT_CHARACTER)
+ c->ts.u.cl->backend_decl
+ = build_int_cst (gfc_charlen_type_node, 0);
field_type = gfc_typenode_for_spec (&c->ts);
}
/* This returns an array descriptor type. Initialization may be
required. */
- if (c->attr.dimension && !c->attr.proc_pointer)
+ if ((c->attr.dimension || c->attr.codimension) && !c->attr.proc_pointer )
{
if (c->attr.pointer || c->attr.allocatable)
{
!c->attr.target);
}
else if ((c->attr.pointer || c->attr.allocatable)
- && !c->attr.proc_pointer)
+ && !c->attr.proc_pointer
+ && !(unlimited_entity && c == derived->components))
field_type = build_pointer_type (field_type);
+ if (c->attr.pointer)
+ field_type = gfc_nonrestricted_type (field_type);
+
/* vtype fields can point to different types to the base type. */
- if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.vtype)
+ if (c->ts.type == BT_DERIVED
+ && c->ts.u.derived && c->ts.u.derived->attr.vtype)
field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
ptr_mode, true);
+ /* Ensure that the CLASS language specific flag is set. */
+ if (c->ts.type == BT_CLASS)
+ {
+ if (POINTER_TYPE_P (field_type))
+ GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1;
+ else
+ GFC_CLASS_TYPE_P (field_type) = 1;
+ }
+
field = gfc_add_field_to_struct (typenode,
get_identifier (c->name),
field_type, &chain);
else if (derived->declared_at.lb)
gfc_set_decl_location (field, &derived->declared_at);
+ gfc_finish_decl_attrs (field, &c->attr);
+
DECL_PACKED (field) |= TYPE_PACKED (typenode);
gcc_assert (field);
-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
+ if (flag_f2c && sym->ts.type == BT_COMPLEX
&& !sym->attr.intrinsic && !sym->attr.always_explicit)
return 1;
spec[spec_len++] = 'R';
}
- for (f = sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
if (spec_len < sizeof (spec))
{
if (!f->sym || f->sym->attr.pointer || f->sym->attr.target
gfc_get_function_type (gfc_symbol * sym)
{
tree type;
- tree typelist;
+ vec<tree, va_gc> *typelist = NULL;
gfc_formal_arglist *f;
gfc_symbol *arg;
- int alternate_return;
+ int alternate_return = 0;
+ bool is_varargs = true;
/* 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)
+ /* To avoid recursing infinitely on recursive types, we use error_mark_node
+ so that they can be detected here and handled further down. */
+ if (sym->backend_decl == NULL)
+ sym->backend_decl = error_mark_node;
+ else if (sym->backend_decl == error_mark_node)
+ goto arg_type_list_done;
+ else if (sym->attr.proc_pointer)
+ return TREE_TYPE (TREE_TYPE (sym->backend_decl));
+ else
return TREE_TYPE (sym->backend_decl);
- alternate_return = 0;
- typelist = NULL_TREE;
-
if (sym->attr.entry_master)
- {
- /* Additional parameter for selecting an entry point. */
- typelist = gfc_chainon_list (typelist, gfc_array_index_type);
- }
+ /* Additional parameter for selecting an entry point. */
+ vec_safe_push (typelist, gfc_array_index_type);
if (sym->result)
arg = sym->result;
|| arg->ts.type == BT_CHARACTER)
type = build_reference_type (type);
- typelist = gfc_chainon_list (typelist, type);
+ vec_safe_push (typelist, type);
if (arg->ts.type == BT_CHARACTER)
{
if (!arg->ts.deferred)
/* Transfer by value. */
- typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
+ vec_safe_push (typelist, gfc_charlen_type_node);
else
/* Deferred character lengths are transferred by reference
so that the value can be returned. */
- typelist = gfc_chainon_list (typelist,
- build_pointer_type (gfc_charlen_type_node));
+ vec_safe_push (typelist, build_pointer_type(gfc_charlen_type_node));
}
}
/* Build the argument types for the function. */
- for (f = sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
{
arg = f->sym;
if (arg)
used without an explicit interface, and cannot be passed as
actual parameters for a dummy procedure. */
- typelist = gfc_chainon_list (typelist, type);
+ vec_safe_push (typelist, type);
}
else
{
}
/* Add hidden string length parameters. */
- for (f = sym->formal; f; f = f->next)
+ for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)
{
arg = f->sym;
if (arg && arg->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
so that the value can be returned. */
type = build_pointer_type (gfc_charlen_type_node);
- typelist = gfc_chainon_list (typelist, type);
+ vec_safe_push (typelist, type);
}
}
- if (typelist)
- typelist = chainon (typelist, void_list_node);
- else if (sym->attr.is_main_program)
- typelist = void_list_node;
+ if (!vec_safe_is_empty (typelist)
+ || sym->attr.is_main_program
+ || sym->attr.if_source != IFSRC_UNKNOWN)
+ is_varargs = false;
+
+ if (sym->backend_decl == error_mark_node)
+ sym->backend_decl = NULL_TREE;
+
+arg_type_list_done:
if (alternate_return)
type = integer_type_node;
type = void_type_node;
else if (sym->attr.mixed_entry_master)
type = gfc_get_mixed_entry_union (sym->ns);
- else if (gfc_option.flag_f2c
- && sym->ts.type == BT_REAL
+ else if (flag_f2c && sym->ts.type == BT_REAL
&& sym->ts.kind == gfc_default_real_kind
&& !sym->attr.always_explicit)
{
- /* Special case: f2c calling conventions require that (scalar)
+ /* Special case: f2c calling conventions require that (scalar)
default REAL functions return the C type double instead. f2c
compatibility is only an issue with functions that don't
require an explicit interface, as only these could be
else
type = gfc_sym_type (sym);
- type = build_function_type (type, typelist);
+ if (is_varargs)
+ type = build_varargs_function_type_vec (type, typelist);
+ else
+ type = build_function_type_vec (type, typelist);
type = create_fn_spec (sym, type);
return type;
if (bits == TYPE_PRECISION (intTI_type_node))
return intTI_type_node;
#endif
+
+ if (bits <= TYPE_PRECISION (intQI_type_node))
+ return intQI_type_node;
+ if (bits <= TYPE_PRECISION (intHI_type_node))
+ return intHI_type_node;
+ if (bits <= TYPE_PRECISION (intSI_type_node))
+ return intSI_type_node;
+ if (bits <= TYPE_PRECISION (intDI_type_node))
+ return intDI_type_node;
+ if (bits <= TYPE_PRECISION (intTI_type_node))
+ return intTI_type_node;
}
else
{
- if (bits == TYPE_PRECISION (unsigned_intQI_type_node))
+ if (bits <= TYPE_PRECISION (unsigned_intQI_type_node))
return unsigned_intQI_type_node;
- if (bits == TYPE_PRECISION (unsigned_intHI_type_node))
+ if (bits <= TYPE_PRECISION (unsigned_intHI_type_node))
return unsigned_intHI_type_node;
- if (bits == TYPE_PRECISION (unsigned_intSI_type_node))
+ if (bits <= TYPE_PRECISION (unsigned_intSI_type_node))
return unsigned_intSI_type_node;
- if (bits == TYPE_PRECISION (unsigned_intDI_type_node))
+ if (bits <= TYPE_PRECISION (unsigned_intDI_type_node))
return unsigned_intDI_type_node;
- if (bits == TYPE_PRECISION (unsigned_intTI_type_node))
+ if (bits <= TYPE_PRECISION (unsigned_intTI_type_node))
return unsigned_intTI_type_node;
}
integer, then UNSIGNEDP selects between signed and unsigned types. */
tree
-gfc_type_for_mode (enum machine_mode mode, int unsignedp)
+gfc_type_for_mode (machine_mode mode, int unsignedp)
{
int i;
tree *base;
else if (GET_MODE_CLASS (mode) == MODE_COMPLEX_FLOAT)
base = gfc_complex_types;
else if (SCALAR_INT_MODE_P (mode))
- return gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
+ {
+ tree type = gfc_type_for_size (GET_MODE_PRECISION (mode), unsignedp);
+ return type != NULL_TREE && mode == TYPE_MODE (type) ? type : NULL_TREE;
+ }
else if (VECTOR_MODE_P (mode))
{
- enum machine_mode inner_mode = GET_MODE_INNER (mode);
+ machine_mode inner_mode = GET_MODE_INNER (mode);
tree inner_type = gfc_type_for_mode (inner_mode, unsignedp);
if (inner_type != NULL_TREE)
return build_vector_type_for_mode (inner_type, mode);
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);
+
+ /* If the type is not a scalar coarray. */
+ if (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;
memset (info, '\0', sizeof (*info));
info->ndimensions = rank;
+ info->ordering = array_descr_ordering_column_major;
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 (input_location, VAR_DECL, NULL_TREE,
- indirect ? build_pointer_type (ptype) : ptype);
+ base_decl = make_node (DEBUG_EXPR_DECL);
+ DECL_ARTIFICIAL (base_decl) = 1;
+ TREE_TYPE (base_decl) = indirect ? build_pointer_type (ptype) : ptype;
+ DECL_MODE (base_decl) = TYPE_MODE (TREE_TYPE (base_decl));
GFC_TYPE_ARRAY_BASE_DECL (type, indirect) = base_decl;
}
info->base_decl = base_decl;
t = base_decl;
if (!integer_zerop (data_off))
- t = build2 (POINTER_PLUS_EXPR, ptype, t, data_off);
+ t = fold_build_pointer_plus (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)
for (dim = 0; dim < rank; dim++)
{
- t = build2 (POINTER_PLUS_EXPR, ptype, base_decl,
- size_binop (PLUS_EXPR, dim_off, lower_suboff));
+ t = fold_build_pointer_plus (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 = fold_build_pointer_plus (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
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 = fold_build_pointer_plus (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;
return true;
}
+
+/* Create a type to handle vector subscripts for coarray library calls. It
+ has the form:
+ struct caf_vector_t {
+ size_t nvec; // size of the vector
+ union {
+ struct {
+ void *vector;
+ int kind;
+ } v;
+ struct {
+ ptrdiff_t lower_bound;
+ ptrdiff_t upper_bound;
+ ptrdiff_t stride;
+ } triplet;
+ } u;
+ }
+ where nvec == 0 for DIMEN_ELEMENT or DIMEN_RANGE and nvec being the vector
+ size in case of DIMEN_VECTOR, where kind is the integer type of the vector. */
+
+tree
+gfc_get_caf_vector_type (int dim)
+{
+ static tree vector_types[GFC_MAX_DIMENSIONS];
+ static tree vec_type = NULL_TREE;
+ tree triplet_struct_type, vect_struct_type, union_type, tmp, *chain;
+
+ if (vector_types[dim-1] != NULL_TREE)
+ return vector_types[dim-1];
+
+ if (vec_type == NULL_TREE)
+ {
+ chain = 0;
+ vect_struct_type = make_node (RECORD_TYPE);
+ tmp = gfc_add_field_to_struct_1 (vect_struct_type,
+ get_identifier ("vector"),
+ pvoid_type_node, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (vect_struct_type,
+ get_identifier ("kind"),
+ integer_type_node, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ gfc_finish_type (vect_struct_type);
+
+ chain = 0;
+ triplet_struct_type = make_node (RECORD_TYPE);
+ tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
+ get_identifier ("lower_bound"),
+ gfc_array_index_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (triplet_struct_type,
+ get_identifier ("upper_bound"),
+ gfc_array_index_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (triplet_struct_type, get_identifier ("stride"),
+ gfc_array_index_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ gfc_finish_type (triplet_struct_type);
+
+ chain = 0;
+ union_type = make_node (UNION_TYPE);
+ tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("v"),
+ vect_struct_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (union_type, get_identifier ("triplet"),
+ triplet_struct_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ gfc_finish_type (union_type);
+
+ chain = 0;
+ vec_type = make_node (RECORD_TYPE);
+ tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("nvec"),
+ size_type_node, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ tmp = gfc_add_field_to_struct_1 (vec_type, get_identifier ("u"),
+ union_type, &chain);
+ TREE_NO_WARNING (tmp) = 1;
+ gfc_finish_type (vec_type);
+ TYPE_NAME (vec_type) = get_identifier ("caf_vector_t");
+ }
+
+ tmp = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+ gfc_rank_cst[dim-1]);
+ vector_types[dim-1] = build_array_type (vec_type, tmp);
+ return vector_types[dim-1];
+}
+
#include "gt-fortran-trans-types.h"
projects / gcc.git / blobdiff