/* Backend support for Fortran 95 basic types and derived types.
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ 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>
int gfc_character_storage_size;
-/* Validate that the f90_type of the given gfc_typespec is valid for
- the type it represents. The f90_type represents the Fortran types
- this C kind can be used with. For example, c_int has a f90_type of
- BT_INTEGER and c_float has a f90_type of BT_REAL. Returns FAILURE
- if a mismatch occurs between ts->f90_type and ts->type; SUCCESS if
- they match. */
-
-try
-gfc_validate_c_kind (gfc_typespec *ts)
-{
- return ((ts->type == ts->f90_type) ? SUCCESS : FAILURE);
-}
-
-
-try
+gfc_try
gfc_check_any_c_kind (gfc_typespec *ts)
{
int i;
return -1;
}
+/* Return a typenode for the "standard" C type with a given name. */
+static tree
+get_typenode_from_name (const char *name)
+{
+ if (name == NULL || *name == '\0')
+ return NULL_TREE;
+
+ if (strcmp (name, "char") == 0)
+ return char_type_node;
+ if (strcmp (name, "unsigned char") == 0)
+ return unsigned_char_type_node;
+ if (strcmp (name, "signed char") == 0)
+ return signed_char_type_node;
+
+ if (strcmp (name, "short int") == 0)
+ return short_integer_type_node;
+ if (strcmp (name, "short unsigned int") == 0)
+ return short_unsigned_type_node;
+
+ if (strcmp (name, "int") == 0)
+ return integer_type_node;
+ if (strcmp (name, "unsigned int") == 0)
+ return unsigned_type_node;
+
+ if (strcmp (name, "long int") == 0)
+ return long_integer_type_node;
+ if (strcmp (name, "long unsigned int") == 0)
+ return long_unsigned_type_node;
+
+ if (strcmp (name, "long long int") == 0)
+ return long_long_integer_type_node;
+ if (strcmp (name, "long long unsigned int") == 0)
+ return long_long_unsigned_type_node;
+
+ gcc_unreachable ();
+}
+
+static int
+get_int_kind_from_name (const char *name)
+{
+ return get_int_kind_from_node (get_typenode_from_name (name));
+}
+
+
+/* Get the kind number corresponding to an integer of given size,
+ following the required return values for ISO_FORTRAN_ENV INT* constants:
+ -2 is returned if we support a kind of larger size, -1 otherwise. */
+int
+gfc_get_int_kind_from_width_isofortranenv (int size)
+{
+ int i;
+
+ /* Look for a kind with matching storage size. */
+ for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+ if (gfc_integer_kinds[i].bit_size == size)
+ return gfc_integer_kinds[i].kind;
+
+ /* Look for a kind with larger storage size. */
+ for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+ if (gfc_integer_kinds[i].bit_size > size)
+ return -2;
+
+ return -1;
+}
+
+/* Get the kind number corresponding to a real of given storage size,
+ following the required return values for ISO_FORTRAN_ENV REAL* constants:
+ -2 is returned if we support a kind of larger size, -1 otherwise. */
+int
+gfc_get_real_kind_from_width_isofortranenv (int size)
+{
+ int i;
+
+ size /= 8;
+
+ /* Look for a kind with matching storage size. */
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) == size)
+ return gfc_real_kinds[i].kind;
+
+ /* Look for a kind with larger storage size. */
+ for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+ if (int_size_in_bytes (gfc_get_real_type (gfc_real_kinds[i].kind)) > size)
+ return -2;
+
+ return -1;
+}
+
+
+
static int
get_int_kind_from_width (int size)
{
void
gfc_init_kinds (void)
{
- enum machine_mode mode;
+ unsigned int mode;
int i_index, r_index, kind;
bool saw_i4 = false, saw_i8 = false;
bool saw_r4 = false, saw_r8 = false, saw_r16 = false;
{
int kind, bitsize;
- if (!targetm.scalar_mode_supported_p (mode))
+ if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
continue;
/* The middle end doesn't support constants larger than 2*HWI.
for (r_index = 0, mode = MIN_MODE_FLOAT; mode <= MAX_MODE_FLOAT; mode++)
{
- const struct real_format *fmt = REAL_MODE_FORMAT (mode);
+ const struct real_format *fmt =
+ REAL_MODE_FORMAT ((enum machine_mode) mode);
int kind;
if (fmt == NULL)
continue;
- if (!targetm.scalar_mode_supported_p (mode))
+ if (!targetm.scalar_mode_supported_p ((enum machine_mode) mode))
continue;
/* Only let float/double/long double go through because the fortran
if (kind == 16)
saw_r16 = true;
- /* Careful we don't stumble a wierd internal mode. */
+ /* Careful we don't stumble a weird internal mode. */
gcc_assert (r_index <= 0 || gfc_real_kinds[r_index-1].kind != kind);
/* Or have too many modes for the allocated space. */
gcc_assert (r_index != MAX_REAL_KINDS);
gfc_default_integer_kind = 8;
/* Even if the user specified that the default integer kind be 8,
- the numerica storage size isn't 64. In this case, a warning will
+ the numeric storage size isn't 64. In this case, a warning will
be issued when NUMERIC_STORAGE_SIZE is used. */
gfc_numeric_storage_size = 4 * 8;
}
return new_type;
}
+
#if 0
/* Return the bit size of the C "size_t". */
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), "integer(kind=%d)",
gfc_integer_kinds[index].kind);
ARRAYS comment.
The data component points to the first element in the array. The
- offset field is the position of the origin of the array (ie element
- (0, 0 ...)). This may be outsite the bounds of the array.
+ offset field is the position of the origin of the array (i.e. element
+ (0, 0 ...)). This may be outside the bounds of the array.
An element is accessed by
data[offset + index0*stride0 + index1*stride1 + index2*stride2]
elements of the origin (2^63 on 64-bit machines). For example
integer, dimension (80000:90000, 80000:90000, 2) :: array
may not work properly on 32-bit machines because 80000*80000 >
- 2^31, so the calculation for stride02 would overflow. This may
+ 2^31, so the calculation for stride2 would overflow. This may
still work, but I haven't checked, and it relies on the overflow
doing the right thing.
mpz_clear (stride);
mpz_clear (delta);
- /* In debug info represent packed arrays as multi-dimensional
- if they have rank > 1 and with proper bounds, instead of flat
- arrays. */
- if (known_offset && write_symbols != NO_DEBUG)
+ /* 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;
tree type;
int byref;
+ /* Procedure Pointers inside COMMON blocks. */
+ if (sym->attr.proc_pointer && sym->attr.in_common)
+ {
+ /* Unset proc_pointer as gfc_get_function_type calls gfc_sym_type. */
+ sym->attr.proc_pointer = 0;
+ type = build_pointer_type (gfc_get_function_type (sym));
+ sym->attr.proc_pointer = 1;
+ return type;
+ }
+
if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
return void_type_node;
if (sym->backend_decl && !sym->attr.function)
return TREE_TYPE (sym->backend_decl);
- if (sym->ts.type == BT_CHARACTER && sym->attr.is_bind_c
- && (sym->attr.function || sym->attr.result))
+ 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);
for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
{
to_cm->backend_decl = from_cm->backend_decl;
- if (!from_cm->pointer && from_cm->ts.type == BT_DERIVED)
+ if (!from_cm->attr.pointer && from_cm->ts.type == BT_DERIVED)
gfc_get_derived_type (to_cm->ts.derived);
else if (from_cm->ts.type == BT_CHARACTER)
}
+/* Build a tree node for a procedure pointer component. */
+
+tree
+gfc_get_ppc_type (gfc_component* c)
+{
+ tree t;
+ if (c->attr.function)
+ 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
/* derived->backend_decl != 0 means we saw it before, but its
components' backend_decl may have not been built. */
if (derived->backend_decl)
- {
- /* Its components' backend_decl have been built. */
- if (TYPE_FIELDS (derived->backend_decl))
- return derived->backend_decl;
- else
- typenode = derived->backend_decl;
- }
+ return derived->backend_decl;
else
{
-
/* We see this derived type first time, so build the type node. */
typenode = make_node (RECORD_TYPE);
TYPE_NAME (typenode) = get_identifier (derived->name);
if (c->ts.type != BT_DERIVED)
continue;
- if (!c->pointer || c->ts.derived->backend_decl == NULL)
+ if (!c->attr.pointer || c->ts.derived->backend_decl == NULL)
c->ts.derived->backend_decl = gfc_get_derived_type (c->ts.derived);
if (c->ts.derived && c->ts.derived->attr.is_iso_c)
{
if (c->ts.type == BT_DERIVED)
field_type = c->ts.derived->backend_decl;
+ else if (c->attr.proc_pointer)
+ field_type = gfc_get_ppc_type (c);
else
{
if (c->ts.type == BT_CHARACTER)
/* This returns an array descriptor type. Initialization may be
required. */
- if (c->dimension)
+ if (c->attr.dimension)
{
- if (c->pointer || c->allocatable)
+ if (c->attr.pointer || c->attr.allocatable)
{
enum gfc_array_kind akind;
- if (c->pointer)
+ if (c->attr.pointer)
akind = GFC_ARRAY_POINTER;
else
akind = GFC_ARRAY_ALLOCATABLE;
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,
gfc_finish_type (typenode);
gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at);
+ if (derived->module && derived->ns->proc_name
+ && derived->ns->proc_name->attr.flavor == FL_MODULE)
+ {
+ if (derived->ns->proc_name->backend_decl
+ && TREE_CODE (derived->ns->proc_name->backend_decl)
+ == NAMESPACE_DECL)
+ {
+ TYPE_CONTEXT (typenode) = derived->ns->proc_name->backend_decl;
+ DECL_CONTEXT (TYPE_STUB_DECL (typenode))
+ = derived->ns->proc_name->backend_decl;
+ }
+ }
derived->backend_decl = typenode;
- /* Add this backend_decl to all the other, equal derived types. */
- for (dt = gfc_derived_types; dt; dt = dt->next)
- copy_dt_decls_ifequal (derived, dt->derived);
+ /* Add this backend_decl to all the other, equal derived types. */
+ for (dt = gfc_derived_types; dt; dt = dt->next)
+ copy_dt_decls_ifequal (derived, dt->derived);
return derived->backend_decl;
}
if (sym->attr.dimension)
return 1;
- if (sym->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)
+ if (sym->ts.type == BT_CHARACTER
+ && !sym->attr.is_bind_c
+ && (!sym->attr.result
+ || !sym->ns->proc_name
+ || !sym->ns->proc_name->attr.is_bind_c))
return 1;
/* Possibly return complex numbers by reference for g77 compatibility.
type = gfc_typenode_for_spec (&sym->ts);
sym->ts.kind = gfc_default_real_kind;
}
+ else if (sym->result && sym->result->attr.proc_pointer)
+ /* Procedure pointer return values. */
+ {
+ if (sym->result->attr.result && strcmp (sym->name,"ppr@") != 0)
+ {
+ /* Unset proc_pointer as gfc_get_function_type
+ is called recursively. */
+ sym->result->attr.proc_pointer = 0;
+ type = build_pointer_type (gfc_get_function_type (sym->result));
+ sym->result->attr.proc_pointer = 1;
+ }
+ else
+ type = gfc_sym_type (sym->result);
+ }
else
type = gfc_sym_type (sym);
}
/* Handle TImode as a special case because it is used by some backends
- (eg. ARM) even though it is not available for normal use. */
+ (e.g. ARM) even though it is not available for normal use. */
#if HOST_BITS_PER_WIDE_INT >= 64
if (bits == TYPE_PRECISION (intTI_type_node))
return intTI_type_node;
else
info->base_decl = base_decl = build_decl (VAR_DECL, NULL_TREE, ptype);
- elem_size = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (etype));
+ 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);
projects / gcc.git / blobdiff