/* Backend support for Fortran 95 basic types and derived types.
- Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 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, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* trans-types.c -- gfortran backend types */
#include "system.h"
#include "coretypes.h"
#include "tree.h"
+#include "langhooks.h"
#include "tm.h"
#include "target.h"
#include "ggc.h"
#include "trans-types.h"
#include "trans-const.h"
#include "real.h"
+#include "flags.h"
+#include "dwarf2out.h"
\f
#if (GFC_MAX_DIMENSIONS < 10)
#error If you really need >99 dimensions, continue the sequence above...
#endif
+/* array of structs so we don't have to worry about xmalloc or free */
+CInteropKind_t c_interop_kinds_table[ISOCBINDING_NUMBER];
+
static tree gfc_get_derived_type (gfc_symbol * derived);
tree gfc_array_index_type;
+tree gfc_array_range_type;
+tree gfc_character1_type_node;
tree pvoid_type_node;
tree ppvoid_type_node;
tree pchar_type_node;
-tree gfc_character1_type_node;
+tree pfunc_type_node;
+
tree gfc_charlen_type_node;
static GTY(()) tree gfc_desc_dim_type;
static GTY(()) tree gfc_max_array_element_size;
+static GTY(()) tree gfc_array_descriptor_base[GFC_MAX_DIMENSIONS];
/* Arrays for all integral and real kinds. We'll fill this in at runtime
after the target has a chance to process command-line options. */
static GTY(()) tree gfc_integer_types[MAX_INT_KINDS + 1];
static GTY(()) tree gfc_logical_types[MAX_INT_KINDS + 1];
-#define MAX_REAL_KINDS 4
+#define MAX_REAL_KINDS 5
gfc_real_info gfc_real_kinds[MAX_REAL_KINDS + 1];
static GTY(()) tree gfc_real_types[MAX_REAL_KINDS + 1];
static GTY(()) tree gfc_complex_types[MAX_REAL_KINDS + 1];
+#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. */
/* The default kinds of the various types. */
int gfc_default_integer_kind;
+int gfc_max_integer_kind;
int gfc_default_real_kind;
int gfc_default_double_kind;
int gfc_default_character_kind;
int gfc_default_complex_kind;
int gfc_c_int_kind;
+/* The kind size used for record offsets. If the target system supports
+ kind=8, this will be set to 8, otherwise it is set to 4. */
+int gfc_intio_kind;
+
+/* The integer kind used to store character lengths. */
+int gfc_charlen_int_kind;
+
+/* The size of the numeric storage unit and character storage unit. */
+int gfc_numeric_storage_size;
+int gfc_character_storage_size;
+
+
+gfc_try
+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.
+ This can be used after verify_c_interop to make sure that the
+ 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 FAILURE;
+}
+
+
+static int
+get_real_kind_from_node (tree type)
+{
+ int i;
+
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ if (gfc_real_kinds[i].mode_precision == TYPE_PRECISION (type))
+ return gfc_real_kinds[i].kind;
+
+ return -4;
+}
+
+static int
+get_int_kind_from_node (tree type)
+{
+ int i;
+
+ if (!type)
+ return -2;
+
+ for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+ if (gfc_integer_kinds[i].bit_size == TYPE_PRECISION (type))
+ return gfc_integer_kinds[i].kind;
+
+ 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)
+{
+ int i;
+
+ for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+ if (gfc_integer_kinds[i].bit_size == size)
+ return gfc_integer_kinds[i].kind;
+
+ return -2;
+}
+
+static int
+get_int_kind_from_minimal_width (int size)
+{
+ int i;
+
+ for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+ if (gfc_integer_kinds[i].bit_size >= size)
+ return gfc_integer_kinds[i].kind;
+
+ return -2;
+}
+
+
+/* Generate the CInteropKind_t objects for the C interoperable
+ kinds. */
+
+static
+void init_c_interop_kinds (void)
+{
+ int i;
+
+ /* init all pointers in the list to NULL */
+ for (i = 0; i < ISOCBINDING_NUMBER; i++)
+ {
+ /* Initialize the name and value fields. */
+ c_interop_kinds_table[i].name[0] = '\0';
+ c_interop_kinds_table[i].value = -100;
+ c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
+ }
+
+#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;
+#define NAMED_REALCST(a,b,c) \
+ 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) \
+ 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;
+#define NAMED_LOGCST(a,b,c) \
+ strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
+ c_interop_kinds_table[a].value = c;
+#define NAMED_CHARKNDCST(a,b,c) \
+ strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
+ c_interop_kinds_table[a].value = c;
+#define NAMED_CHARCST(a,b,c) \
+ strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
+ c_interop_kinds_table[a].value = c;
+#define DERIVED_TYPE(a,b,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) \
+ 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"
+}
+
+
/* Query the target to determine which machine modes are available for
computation. Choose KIND numbers for them. */
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.
i_index += 1;
}
+ /* Set the kind used to match GFC_INT_IO in libgfortran. This is
+ used for large file access. */
+
+ if (saw_i8)
+ gfc_intio_kind = 8;
+ else
+ gfc_intio_kind = 4;
+
+ /* If we do not at least have kind = 4, everything is pointless. */
+ gcc_assert(saw_i4);
+
+ /* Set the maximum integer kind. Used with at least BOZ constants. */
+ gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
+
for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
{
- const struct real_format *fmt = REAL_MODE_FORMAT (mode);
+ 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
+ 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,
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_real_kinds[r_index].digits = fmt->p;
gfc_real_kinds[r_index].min_exponent = fmt->emin;
gfc_real_kinds[r_index].max_exponent = fmt->emax;
+ if (fmt->pnan < fmt->p)
+ /* This is an IBM extended double format (or the MIPS variant)
+ made up of two IEEE doubles. The value of the long double is
+ the sum of the values of the two parts. The most significant
+ part is required to be the value of the long double rounded
+ to the nearest double. If we use emax of 1024 then we can't
+ represent huge(x) = (1 - b**(-p)) * b**(emax-1) * b, because
+ rounding will make the most significant part overflow. */
+ gfc_real_kinds[r_index].max_exponent = fmt->emax - 1;
gfc_real_kinds[r_index].mode_precision = GET_MODE_PRECISION (mode);
r_index += 1;
}
/* Choose the default integer kind. We choose 4 unless the user
directs us otherwise. */
- if (gfc_option.i8)
+ if (gfc_option.flag_default_integer)
{
if (!saw_i8)
- fatal_error ("integer kind=8 not available for -i8 option");
+ fatal_error ("integer kind=8 not available for -fdefault-integer-8 option");
gfc_default_integer_kind = 8;
+
+ /* Even if the user specified that the default integer kind be 8,
+ the 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 (saw_i4)
- gfc_default_integer_kind = 4;
+ {
+ gfc_default_integer_kind = 4;
+ gfc_numeric_storage_size = 4 * 8;
+ }
else
- gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
+ {
+ gfc_default_integer_kind = gfc_integer_kinds[i_index - 1].kind;
+ gfc_numeric_storage_size = gfc_integer_kinds[i_index - 1].bit_size;
+ }
/* Choose the default real kind. Again, we choose 4 when possible. */
- if (gfc_option.r8)
+ if (gfc_option.flag_default_real)
{
if (!saw_r8)
- fatal_error ("real kind=8 not available for -r8 option");
+ fatal_error ("real kind=8 not available for -fdefault-real-8 option");
gfc_default_real_kind = 8;
}
else if (saw_r4)
else
gfc_default_real_kind = gfc_real_kinds[0].kind;
- /* Choose the default double kind. If -r8 is specified, we use kind=16,
- if it's available, otherwise we do not change anything. */
- if (gfc_option.r8 && saw_r16)
+ /* Choose the default double kind. If -fdefault-real and -fdefault-double
+ are specified, we use kind=8, if it's available. If -fdefault-real is
+ specified without -fdefault-double, we use kind=16, if it's available.
+ Otherwise we do not change anything. */
+ if (gfc_option.flag_default_double && !gfc_option.flag_default_real)
+ fatal_error ("Use of -fdefault-double-8 requires -fdefault-real-8");
+
+ if (gfc_option.flag_default_real && gfc_option.flag_default_double && saw_r8)
+ gfc_default_double_kind = 8;
+ else if (gfc_option.flag_default_real && saw_r16)
gfc_default_double_kind = 16;
else if (saw_r4 && saw_r8)
gfc_default_double_kind = 8;
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. */
gfc_index_integer_kind = POINTER_SIZE / 8;
/* 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();
}
/* Make sure that a valid kind is present. Returns an index into the
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,
+ 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
boolean_false_node = build_int_cst (boolean_type_node, 0);
/* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
- gfc_charlen_type_node = gfc_get_int_type (4);
+ gfc_charlen_int_kind = 4;
+ gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind);
}
/* Get the type node for the given type and kind. */
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];
+}
+
+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_array_index_type, gfc_index_one_node, len);
- type = build_array_type (gfc_character1_type_node, bounds);
+ bounds = build_range_type (gfc_charlen_type_node, gfc_index_one_node, len);
+ 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. */
gcc_unreachable ();
case BT_INTEGER:
- basetype = gfc_get_int_type (spec->kind);
+ /* We use INTEGER(c_intptr_t) for C_PTR and C_FUNPTR once the symbol
+ 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)
+ {
+ 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;
case BT_REAL:
case BT_DERIVED:
basetype = gfc_get_derived_type (spec->derived);
- break;
+ /* 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->derived->attr.is_iso_c)
+ {
+ spec->type = spec->derived->ts.type;
+ spec->kind = spec->derived->ts.kind;
+ spec->f90_type = spec->derived->ts.f90_type;
+ }
+ 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;
+ 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 ();
}
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);
return element;
}
\f
-/* Build an array. This function is called from gfc_sym_type().
+/* Build an array. This function is called from gfc_sym_type().
Actually returns array descriptor type.
Format of array descriptors is as follows:
index ubound;
}
- Translation code should use gfc_conv_descriptor_* rather than accessing
- the descriptor directly. Any changes to the array descriptor type will
- require changes in gfc_conv_descriptor_* and gfc_build_array_initializer.
+ Translation code should use gfc_conv_descriptor_* rather than
+ accessing the descriptor directly. Any changes to the array
+ descriptor type will require changes in gfc_conv_descriptor_* and
+ gfc_build_array_initializer.
- This is represented internally as a RECORD_TYPE. The index nodes are
- gfc_array_index_type and the data node is a pointer to the data. See below
- for the handling of character types.
+ This is represented internally as a RECORD_TYPE. The index nodes
+ are gfc_array_index_type and the data node is a pointer to the
+ data. See below for the handling of character types.
The dtype member is formatted as follows:
rank = dtype & GFC_DTYPE_RANK_MASK // 3 bits
type = (dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT // 3 bits
size = dtype >> GFC_DTYPE_SIZE_SHIFT
- I originally used nested ARRAY_TYPE nodes to represent arrays, but this
- generated poor code for assumed/deferred size arrays. These require
- use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part of the GENERIC
- grammar. Also, there is no way to explicitly set the array stride, so
- all data must be packed(1). I've tried to mark all the functions which
- would require modification with a GCC ARRAYS comment.
+ I originally used nested ARRAY_TYPE nodes to represent arrays, but
+ this generated poor code for assumed/deferred size arrays. These
+ require use of PLACEHOLDER_EXPR/WITH_RECORD_EXPR, which isn't part
+ of the GENERIC grammar. Also, there is no way to explicitly set
+ the array stride, so all data must be packed(1). I've tried to
+ mark all the functions which would require modification with a GCC
+ 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.
+ The data component points to the first element in the array. The
+ 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]
+ data[offset + index0*stride0 + index1*stride1 + index2*stride2]
This gives good performance as the computation does not involve the
- bounds of the array. For packed arrays, this is optimized further by
- substituting the known strides.
+ bounds of the array. For packed arrays, this is optimized further
+ by substituting the known strides.
- This system has one problem: all array bounds must be withing 2^31 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 still work, but
- I haven't checked, and it relies on the overflow doing the right thing.
+ This system has one problem: all array bounds must be within 2^31
+ 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 stride2 would overflow. This may
+ still work, but I haven't checked, and it relies on the overflow
+ doing the right thing.
- The way to fix this problem is to access alements as follows:
- data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
- Obviously this is much slower. I will make this a compile time option,
- something like -fsmall-array-offsets. Mixing code compiled with and without
- this switch will work.
+ The way to fix this problem is to access elements as follows:
+ data[(index0-lbound0)*stride0 + (index1-lbound1)*stride1]
+ Obviously this is much slower. I will make this a compile time
+ option, something like -fsmall-array-offsets. Mixing code compiled
+ with and without this switch will work.
- (1) This can be worked around by modifying the upper bound of the previous
- dimension. This requires extra fields in the descriptor (both real_ubound
- and fake_ubound). In tree.def there is mention of TYPE_SEP, which
- may allow us to do this. However I can't find mention of this anywhere
- else. */
+ (1) This can be worked around by modifying the upper bound of the
+ previous dimension. This requires extra fields in the descriptor
+ (both real_ubound and fake_ubound). */
/* Returns true if the array sym does not require a descriptor. */
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;
/* 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;
}
-static tree
-gfc_get_dtype (tree type, int rank)
+
+/* Return the DTYPE for an array. This describes the type and type parameters
+ of the array. */
+/* TODO: Only call this when the value is actually used, and make all the
+ unknown cases abort. */
+
+tree
+gfc_get_dtype (tree type)
{
tree size;
int n;
HOST_WIDE_INT i;
tree tmp;
tree dtype;
+ tree etype;
+ int rank;
- if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
- return (GFC_TYPE_ARRAY_DTYPE (type));
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type));
- /* TODO: Correctly identify LOGICAL types. */
- switch (TREE_CODE (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))
{
case INTEGER_TYPE:
n = GFC_DTYPE_INTEGER;
n = GFC_DTYPE_COMPLEX;
break;
- /* Arrays have already been dealt with. */
+ /* We will never have arrays of arrays. */
case RECORD_TYPE:
n = GFC_DTYPE_DERIVED;
break;
}
gcc_assert (rank <= GFC_DTYPE_RANK_MASK);
- size = TYPE_SIZE_UNIT (type);
+ size = TYPE_SIZE_UNIT (etype);
i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
if (size && INTEGER_CST_P (size))
if (size && !INTEGER_CST_P (size))
{
tmp = build_int_cst (gfc_array_index_type, GFC_DTYPE_SIZE_SHIFT);
- tmp = fold (build2 (LSHIFT_EXPR, gfc_array_index_type, size, tmp));
- dtype = fold (build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype));
+ tmp = fold_build2 (LSHIFT_EXPR, gfc_array_index_type,
+ fold_convert (gfc_array_index_type, size), tmp);
+ dtype = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, dtype);
}
/* If we don't know the size we leave it as zero. This should never happen
for anything that is actually used. */
/* TODO: Check this is actually true, particularly when repacking
assumed size parameters. */
+ GFC_TYPE_ARRAY_DTYPE (type) = dtype;
return dtype;
}
-/* Build an array type for use without a descriptor. Valid values of packed
- are 0=no, 1=partial, 2=full, 3=static. */
+/* Build an array type for use without a descriptor, packed according
+ to the value of PACKED. */
tree
-gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, int packed)
+gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed)
{
tree range;
tree type;
TYPE_LANG_SPECIFIC (type) = (struct lang_type *)
ggc_alloc_cleared (sizeof (struct lang_type));
- known_stride = (packed != 0);
+ known_stride = (packed != PACKED_NO);
known_offset = 1;
for (n = 0; n < as->rank; n++)
{
/* 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
{
}
/* Only the first stride is known for partial packed arrays. */
- if (packed < 2)
+ if (packed == PACKED_NO || packed == PACKED_PARTIAL)
known_stride = 0;
}
else
GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
- GFC_TYPE_ARRAY_DTYPE (type) = gfc_get_dtype (etype, as->rank);
GFC_TYPE_ARRAY_RANK (type) = as->rank;
+ GFC_TYPE_ARRAY_DTYPE (type) = NULL_TREE;
range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
NULL_TREE);
/* TODO: use main type if it is unbounded. */
mpz_clear (stride);
mpz_clear (delta);
- if (packed < 3 || !known_stride)
+ /* 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
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)
+{
+ 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;
+ 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. */
+ 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;
+ 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;
+}
/* Build an array (descriptor) type with given bounds. */
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)
{
- tree fat_type, fat_pointer_type;
- tree fieldlist;
- tree arraytype;
- tree decl;
- int n;
char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
- const char *typename;
- tree lower;
- tree upper;
- tree stride;
- tree tmp;
+ tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
+ const char *type_name;
+ int n;
- /* Build the type node. */
- fat_type = make_node (RECORD_TYPE);
- GFC_DESCRIPTOR_TYPE_P (fat_type) = 1;
- TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
- ggc_alloc_cleared (sizeof (struct lang_type));
- GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
- GFC_TYPE_ARRAY_DTYPE (fat_type) = gfc_get_dtype (etype, dimen);
+ base_type = gfc_get_array_descriptor_base (dimen);
+ fat_type = build_variant_type_copy (base_type);
tmp = TYPE_NAME (etype);
if (tmp && TREE_CODE (tmp) == TYPE_DECL)
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);
- 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;
+ GFC_TYPE_ARRAY_AKIND (fat_type) = akind;
/* 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));
+ /* 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;
- /* 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);
+ /* 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;
}
tree type;
int byref;
- if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
- return void_type_node;
-
- if (sym->backend_decl)
+ /* Procedure Pointers inside COMMON blocks. */
+ if (sym->attr.proc_pointer && sym->attr.in_common)
{
- if (sym->attr.function)
- return TREE_TYPE (TREE_TYPE (sym->backend_decl));
- else
- return TREE_TYPE (sym->backend_decl);
+ /* 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;
}
- /* 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;
+ if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
+ return void_type_node;
- type = gfc_typenode_for_spec (&sym->ts);
+ /* In the case of a function the fake result variable may have a
+ type different from the function type, so don't return early in
+ that case. */
+ if (sym->backend_decl && !sym->attr.function)
+ return TREE_TYPE (sym->backend_decl);
- if (sym->attr.dummy && !sym->attr.function)
+ 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
byref = 0;
/* If this is a character argument of unknown length, just use the
base type. */
if (sym->ts.type != BT_CHARACTER
- || !(sym->attr.dummy || sym->attr.function || sym->attr.result)
+ || !(sym->attr.dummy || sym->attr.function)
|| sym->ts.cl->backend_decl)
{
type = gfc_get_nodesc_array_type (type, sym->as,
- byref ? 2 : 3);
+ byref ? PACKED_FULL
+ : PACKED_STATIC);
byref = 0;
}
}
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.
}
-/* 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->attr.pointer && 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 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
+ in a parent namespace, this is used. */
static tree
gfc_get_derived_type (gfc_symbol * derived)
{
- tree typenode, field, field_type, fieldlist;
+ tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL;
gfc_component *c;
+ gfc_dt_list *dt;
gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
- /* derived->backend_decl != 0 means we saw it before, but its
- components' backend_decl may have not been built. */
- if (derived->backend_decl)
+ /* See if it's one of the iso_c_binding derived types. */
+ if (derived->attr.is_iso_c == 1)
{
- /* Its components' backend_decl have been built. */
- if (TYPE_FIELDS (derived->backend_decl))
- return derived->backend_decl;
+ if (derived->backend_decl)
+ return derived->backend_decl;
+
+ if (derived->intmod_sym_id == ISOCBINDING_PTR)
+ derived->backend_decl = ptr_type_node;
else
- typenode = derived->backend_decl;
+ 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)
+ return derived->backend_decl;
else
{
/* We see this derived type first time, so build the type node. */
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->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)
+ {
+ /* Need to copy the modified ts from the derived type. The
+ typespec was modified because C_PTR/C_FUNPTR are translated
+ into (void *) from derived types. */
+ 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 (TYPE_FIELDS (derived->backend_decl))
+ return derived->backend_decl;
+
/* Build the type member list. Install the newly created RECORD_TYPE
node as DECL_CONTEXT of each FIELD_DECL. */
fieldlist = NULL_TREE;
for (c = derived->components; c; c = c->next)
{
- if (c->ts.type == BT_DERIVED && c->pointer)
- {
- if (c->ts.derived->backend_decl)
- field_type = c->ts.derived->backend_decl;
- else
- {
- /* Build the type node. */
- field_type = make_node (RECORD_TYPE);
- TYPE_NAME (field_type) = get_identifier (c->ts.derived->name);
- TYPE_PACKED (field_type) = gfc_option.flag_pack_derived;
- c->ts.derived->backend_decl = field_type;
- }
- }
+ if (c->ts.type == BT_DERIVED)
+ field_type = c->ts.derived->backend_decl;
+ else if (c->attr.proc_pointer)
+ field_type = gfc_get_ppc_type (c);
else
{
if (c->ts.type == BT_CHARACTER)
field_type = gfc_typenode_for_spec (&c->ts);
}
- /* This returns an array descriptor type. Initialisation may be
+ /* This returns an array descriptor type. Initialization may be
required. */
- if (c->dimension)
+ if (c->attr.dimension && !c->attr.proc_pointer)
{
- if (c->pointer)
+ if (c->attr.pointer || c->attr.allocatable)
{
- /* Pointers to arrays aren't actualy pointer types. The
- descriptors are seperate, but the data is common. */
- field_type = gfc_build_array_type (field_type, c->as);
+ 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, akind);
}
else
- field_type = gfc_get_nodesc_array_type (field_type, c->as, 3);
+ 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);
- 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
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;
- return 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);
+
+ return derived->backend_decl;
}
-\f
+
+
int
gfc_return_by_reference (gfc_symbol * sym)
{
if (!sym->attr.function)
return 0;
- gcc_assert (sym->attr.function);
-
- if (sym->result)
- sym = sym->result;
-
if (sym->attr.dimension)
return 1;
- if (sym->ts.type == BT_CHARACTER)
+ 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.
+ 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;
- /* Possibly return complex numbers by reference for g77 compatibility. */
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);
+ TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (type)) = 1;
+ return type;
+}
+\f
tree
gfc_get_function_type (gfc_symbol * sym)
{
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_DERIVED
+ if (arg->ts.type == BT_COMPLEX
|| arg->attr.dimension
|| arg->ts.type == BT_CHARACTER)
type = build_reference_type (type);
The problem arises if a function is called via an implicit
prototype. In this situation the INTENT is not known.
For this reason all parameters to global functions must be
- passed by reference. Passing by value would potentialy
+ passed by reference. Passing by value would potentially
generate bad code. Worse there would be no way of telling that
this code was bad, except that it would give incorrect results.
Contained procedures could pass by value as these are never
- used without an explicit interface, and connot be passed as
+ used without an explicit interface, and cannot be passed as
actual parameters for a dummy procedure. */
if (arg->ts.type == BT_CHARACTER)
nstr++;
while (nstr--)
typelist = gfc_chainon_list (typelist, gfc_charlen_type_node);
- typelist = gfc_chainon_list (typelist, void_type_node);
+ if (typelist)
+ typelist = gfc_chainon_list (typelist, void_type_node);
if (alternate_return)
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 if (gfc_option.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)
+ 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
+ implemented in Fortran 77. */
+ sym->ts.kind = gfc_default_double_kind;
+ 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);
if (type && bits == TYPE_PRECISION (type))
return type;
}
+
+ /* Handle TImode as a special case because it is used by some backends
+ (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;
+#endif
}
else
{
return NULL_TREE;
}
-/* Return a type the same as TYPE except unsigned or
- signed according to UNSIGNEDP. */
+/* Return TRUE if TYPE is a type with a hidden descriptor, fill in INFO
+ in that case. */
-tree
-gfc_signed_or_unsigned_type (int unsignedp, tree type)
+bool
+gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
{
- if (TREE_CODE (type) != INTEGER_TYPE || TYPE_UNSIGNED (type) == unsignedp)
- return type;
- else
- return gfc_type_for_size (TYPE_PRECISION (type), unsignedp);
-}
+ 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;
-/* Return an unsigned type the same as TYPE in other respects. */
+ 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;
+ }
-tree
-gfc_unsigned_type (tree type)
-{
- return gfc_signed_or_unsigned_type (1, type);
-}
+ 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;
+ }
-/* Return a signed type the same as TYPE in other respects. */
+ 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);
-tree
-gfc_signed_type (tree type)
-{
- return gfc_signed_or_unsigned_type (0, type);
+ 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"
OSDN Git Service
