* *
* C Implementation File *
* *
- * Copyright (C) 1992-2008, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2009, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
* *
****************************************************************************/
-/* We have attribute handlers using C specific format specifiers in warning
- messages. Make sure they are properly recognized. */
-#define GCC_DIAG_STYLE __gcc_cdiag__
-
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tm.h"
#include "tree.h"
#include "flags.h"
-#include "defaults.h"
#include "toplev.h"
+#include "rtl.h"
#include "output.h"
#include "ggc.h"
#include "debug.h"
#include "convert.h"
#include "target.h"
#include "function.h"
+#include "langhooks.h"
+#include "pointer-set.h"
#include "cgraph.h"
+#include "tree-dump.h"
#include "tree-inline.h"
#include "tree-iterator.h"
#include "gimple.h"
-#include "tree-dump.h"
-#include "pointer-set.h"
-#include "langhooks.h"
#include "ada.h"
#include "types.h"
#include "ada-tree.h"
#include "gigi.h"
-#ifndef MAX_FIXED_MODE_SIZE
-#define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
-#endif
-
#ifndef MAX_BITS_PER_WORD
#define MAX_BITS_PER_WORD BITS_PER_WORD
#endif
/* If nonzero, pretend we are allocating at global level. */
int force_global;
+/* The default alignment of "double" floating-point types, i.e. floating
+ point types whose size is equal to 64 bits, or 0 if this alignment is
+ not specifically capped. */
+int double_float_alignment;
+
+/* The default alignment of "double" or larger scalar types, i.e. scalar
+ types whose size is greater or equal to 64 bits, or 0 if this alignment
+ is not specifically capped. */
+int double_scalar_alignment;
+
/* Tree nodes for the various types and decls we create. */
tree gnat_std_decls[(int) ADT_LAST];
static tree handle_noreturn_attribute (tree *, tree, tree, int, bool *);
static tree handle_malloc_attribute (tree *, tree, tree, int, bool *);
static tree handle_type_generic_attribute (tree *, tree, tree, int, bool *);
+static tree handle_vector_size_attribute (tree *, tree, tree, int, bool *);
+static tree handle_vector_type_attribute (tree *, tree, tree, int, bool *);
/* Fake handler for attributes we don't properly support, typically because
they'd require dragging a lot of the common-c front-end circuitry. */
{ "sentinel", 0, 1, false, true, true, handle_sentinel_attribute },
{ "noreturn", 0, 0, true, false, false, handle_noreturn_attribute },
{ "malloc", 0, 0, true, false, false, handle_malloc_attribute },
- { "type generic", 0, 0, false, true, true, handle_type_generic_attribute },
+ { "type generic", 0, 0, false, true, true, handle_type_generic_attribute },
+
+ { "vector_size", 1, 1, false, true, false, handle_vector_size_attribute },
+ { "vector_type", 0, 0, false, true, false, handle_vector_type_attribute },
+ { "may_alias", 0, 0, false, true, false, NULL },
/* ??? format and format_arg are heavy and not supported, which actually
prevents support for stdio builtins, which we however declare as part
/* For each binding contour we allocate a binding_level structure to indicate
the binding depth. */
-struct gnat_binding_level GTY((chain_next ("%h.chain")))
-{
+struct GTY((chain_next ("%h.chain"))) gnat_binding_level {
/* The binding level containing this one (the enclosing binding level). */
struct gnat_binding_level *chain;
/* The BLOCK node for this level. */
/* A chain of unused BLOCK nodes. */
static GTY((deletable)) tree free_block_chain;
-static void gnat_install_builtins (void);
static tree merge_sizes (tree, tree, tree, bool, bool);
static tree compute_related_constant (tree, tree);
static tree split_plus (tree, tree *);
-static void gnat_gimplify_function (tree);
static tree float_type_for_precision (int, enum machine_mode);
static tree convert_to_fat_pointer (tree, tree);
static tree convert_to_thin_pointer (tree, tree);
/* GNAT_ENTITY is a GNAT tree node for an entity. GNU_DECL is the GCC tree
which is to be associated with GNAT_ENTITY. Such GCC tree node is always
- a ..._DECL node. If NO_CHECK is nonzero, the latter check is suppressed.
+ a ..._DECL node. If NO_CHECK is true, the latter check is suppressed.
If GNU_DECL is zero, a previous association is to be reset. */
: ENUMERAL_TYPE);
TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
TYPE_DUMMY_P (gnu_type) = 1;
+ TYPE_STUB_DECL (gnu_type)
+ = create_type_stub_decl (TYPE_NAME (gnu_type), gnu_type);
if (AGGREGATE_TYPE_P (gnu_type))
- {
- TYPE_STUB_DECL (gnu_type) = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
- TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_type);
- }
+ TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_type);
SET_DUMMY_NODE (gnat_underlying, gnu_type);
/* Enter a new binding level. */
void
-gnat_pushlevel ()
+gnat_pushlevel (void)
{
struct gnat_binding_level *newlevel = NULL;
/* Get the jmpbuf_decl, if any, for the current binding level. */
tree
-get_block_jmpbuf_decl ()
+get_block_jmpbuf_decl (void)
{
return current_binding_level->jmpbuf_decl;
}
/* Exit a binding level. Set any BLOCK into the current code group. */
void
-gnat_poplevel ()
+gnat_poplevel (void)
{
struct gnat_binding_level *level = current_binding_level;
tree block = level->block;
{
DECL_CONTEXT (decl) = current_function_decl;
- /* Functions imported in another function are not really nested. */
- if (TREE_CODE (decl) == FUNCTION_DECL && TREE_PUBLIC (decl))
- DECL_NO_STATIC_CHAIN (decl) = 1;
+ /* Functions imported in another function are not really nested.
+ For really nested functions mark them initially as needing
+ a static chain for uses of that flag before unnesting;
+ lower_nested_functions will then recompute it. */
+ if (TREE_CODE (decl) == FUNCTION_DECL && !TREE_PUBLIC (decl))
+ DECL_STATIC_CHAIN (decl) = 1;
}
TREE_NO_WARNING (decl) = (gnat_node == Empty || Warnings_Off (gnat_node));
}
/* For the declaration of a type, set its name if it either is not already
- set, was set to an IDENTIFIER_NODE, indicating an internal name,
- or if the previous type name was not derived from a source name.
+ set or if the previous type name was not derived from a source name.
We'd rather have the type named with a real name and all the pointer
types to the same object have the same POINTER_TYPE node. Code in the
equivalent function of c-decl.c makes a copy of the type node here, but
{
tree t = TREE_TYPE (decl);
- if (!TYPE_NAME (t) || TREE_CODE (TYPE_NAME (t)) == IDENTIFIER_NODE)
+ if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL))
;
- else if (TYPE_FAT_POINTER_P (t))
+ else if (TYPE_IS_FAT_POINTER_P (t))
{
tree tt = build_variant_type_copy (t);
TYPE_NAME (tt) = decl;
TREE_USED (tt) = TREE_USED (t);
TREE_TYPE (decl) = tt;
- DECL_ORIGINAL_TYPE (decl) = t;
+ if (DECL_ORIGINAL_TYPE (TYPE_NAME (t)))
+ DECL_ORIGINAL_TYPE (decl) = DECL_ORIGINAL_TYPE (TYPE_NAME (t));
+ else
+ DECL_ORIGINAL_TYPE (decl) = t;
t = NULL_TREE;
+ DECL_ARTIFICIAL (decl) = 0;
}
else if (DECL_ARTIFICIAL (TYPE_NAME (t)) && !DECL_ARTIFICIAL (decl))
;
build_common_tree_nodes (true, true);
/* In Ada, we use a signed type for SIZETYPE. Use the signed type
- corresponding to the size of Pmode. In most cases when ptr_mode and
- Pmode differ, C will use the width of ptr_mode as sizetype. But we get
- far better code using the width of Pmode. Make this here since we need
- this before we can expand the GNAT types. */
- size_type_node = gnat_type_for_size (GET_MODE_BITSIZE (Pmode), 0);
+ corresponding to the width of Pmode. In most cases when ptr_mode
+ and Pmode differ, C will use the width of ptr_mode for SIZETYPE.
+ But we get far better code using the width of Pmode. */
+ size_type_node = gnat_type_for_mode (Pmode, 0);
set_sizetype (size_type_node);
/* In Ada, we use an unsigned 8-bit type for the default boolean type. */
- boolean_type_node = make_node (BOOLEAN_TYPE);
- TYPE_PRECISION (boolean_type_node) = 1;
- fixup_unsigned_type (boolean_type_node);
- TYPE_RM_SIZE_NUM (boolean_type_node) = bitsize_int (1);
+ boolean_type_node = make_unsigned_type (8);
+ TREE_SET_CODE (boolean_type_node, BOOLEAN_TYPE);
+ SET_TYPE_RM_MAX_VALUE (boolean_type_node,
+ build_int_cst (boolean_type_node, 1));
+ SET_TYPE_RM_SIZE (boolean_type_node, bitsize_int (1));
build_common_tree_nodes_2 (0);
+ boolean_true_node = TYPE_MAX_VALUE (boolean_type_node);
ptr_void_type_node = build_pointer_type (void_type_node);
}
-
-/* Create the predefined scalar types such as `integer_type_node' needed
- in the gcc back-end and initialize the global binding level. */
+\f
+/* Record TYPE as a builtin type for Ada. NAME is the name of the type. */
void
-init_gigi_decls (tree long_long_float_type, tree exception_type)
+record_builtin_type (const char *name, tree type)
{
- tree endlink, decl;
- tree int64_type = gnat_type_for_size (64, 0);
- unsigned int i;
-
- /* Set the types that GCC and Gigi use from the front end. We would like
- to do this for char_type_node, but it needs to correspond to the C
- char type. */
- if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
- {
- /* In this case, the builtin floating point types are VAX float,
- so make up a type for use. */
- longest_float_type_node = make_node (REAL_TYPE);
- TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
- layout_type (longest_float_type_node);
- create_type_decl (get_identifier ("longest float type"),
- longest_float_type_node, NULL, false, true, Empty);
- }
- else
- longest_float_type_node = TREE_TYPE (long_long_float_type);
-
- except_type_node = TREE_TYPE (exception_type);
-
- unsigned_type_node = gnat_type_for_size (INT_TYPE_SIZE, 1);
- create_type_decl (get_identifier ("unsigned int"), unsigned_type_node,
- NULL, false, true, Empty);
-
- void_type_decl_node = create_type_decl (get_identifier ("void"),
- void_type_node, NULL, false, true,
- Empty);
-
- void_ftype = build_function_type (void_type_node, NULL_TREE);
- ptr_void_ftype = build_pointer_type (void_ftype);
-
- /* Build the special descriptor type and its null node if needed. */
- if (TARGET_VTABLE_USES_DESCRIPTORS)
- {
- tree field_list = NULL_TREE, null_list = NULL_TREE;
- int j;
-
- fdesc_type_node = make_node (RECORD_TYPE);
-
- for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
- {
- tree field = create_field_decl (NULL_TREE, ptr_void_ftype,
- fdesc_type_node, 0, 0, 0, 1);
- TREE_CHAIN (field) = field_list;
- field_list = field;
- null_list = tree_cons (field, null_pointer_node, null_list);
- }
-
- finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
- null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_list);
- }
-
- /* Now declare runtime functions. */
- endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
-
- /* malloc is a function declaration tree for a function to allocate
- memory. */
- malloc_decl = create_subprog_decl (get_identifier ("__gnat_malloc"),
- NULL_TREE,
- build_function_type (ptr_void_type_node,
- tree_cons (NULL_TREE,
- sizetype,
- endlink)),
- NULL_TREE, false, true, true, NULL,
- Empty);
- DECL_IS_MALLOC (malloc_decl) = 1;
-
- /* malloc32 is a function declaration tree for a function to allocate
- 32bit memory on a 64bit system. Needed only on 64bit VMS. */
- malloc32_decl = create_subprog_decl (get_identifier ("__gnat_malloc32"),
- NULL_TREE,
- build_function_type (ptr_void_type_node,
- tree_cons (NULL_TREE,
- sizetype,
- endlink)),
- NULL_TREE, false, true, true, NULL,
- Empty);
- DECL_IS_MALLOC (malloc32_decl) = 1;
-
- /* free is a function declaration tree for a function to free memory. */
- free_decl
- = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- ptr_void_type_node,
- endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- /* This is used for 64-bit multiplication with overflow checking. */
- mulv64_decl
- = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
- build_function_type_list (int64_type, int64_type,
- int64_type, NULL_TREE),
- NULL_TREE, false, true, true, NULL, Empty);
-
- /* Make the types and functions used for exception processing. */
- jmpbuf_type
- = build_array_type (gnat_type_for_mode (Pmode, 0),
- build_index_type (build_int_cst (NULL_TREE, 5)));
- create_type_decl (get_identifier ("JMPBUF_T"), jmpbuf_type, NULL,
- true, true, Empty);
- jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
-
- /* Functions to get and set the jumpbuf pointer for the current thread. */
- get_jmpbuf_decl
- = create_subprog_decl
- (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
- NULL_TREE, build_function_type (jmpbuf_ptr_type, NULL_TREE),
- NULL_TREE, false, true, true, NULL, Empty);
- /* Avoid creating superfluous edges to __builtin_setjmp receivers. */
- DECL_PURE_P (get_jmpbuf_decl) = 1;
-
- set_jmpbuf_decl
- = create_subprog_decl
- (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
- NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- /* Function to get the current exception. */
- get_excptr_decl
- = create_subprog_decl
- (get_identifier ("system__soft_links__get_gnat_exception"),
- NULL_TREE,
- build_function_type (build_pointer_type (except_type_node), NULL_TREE),
- NULL_TREE, false, true, true, NULL, Empty);
- /* Avoid creating superfluous edges to __builtin_setjmp receivers. */
- DECL_PURE_P (get_excptr_decl) = 1;
-
- /* Functions that raise exceptions. */
- raise_nodefer_decl
- = create_subprog_decl
- (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- build_pointer_type (except_type_node),
- endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- /* Dummy objects to materialize "others" and "all others" in the exception
- tables. These are exported by a-exexpr.adb, so see this unit for the
- types to use. */
-
- others_decl
- = create_var_decl (get_identifier ("OTHERS"),
- get_identifier ("__gnat_others_value"),
- integer_type_node, 0, 1, 0, 1, 1, 0, Empty);
-
- all_others_decl
- = create_var_decl (get_identifier ("ALL_OTHERS"),
- get_identifier ("__gnat_all_others_value"),
- integer_type_node, 0, 1, 0, 1, 1, 0, Empty);
-
- /* Hooks to call when entering/leaving an exception handler. */
- begin_handler_decl
- = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- ptr_void_type_node,
- endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- end_handler_decl
- = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- ptr_void_type_node,
- endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- /* If in no exception handlers mode, all raise statements are redirected to
- __gnat_last_chance_handler. No need to redefine raise_nodefer_decl, since
- this procedure will never be called in this mode. */
- if (No_Exception_Handlers_Set ())
- {
- decl
- = create_subprog_decl
- (get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- build_pointer_type (char_type_node),
- tree_cons (NULL_TREE,
- integer_type_node,
- endlink))),
- NULL_TREE, false, true, true, NULL, Empty);
-
- for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
- gnat_raise_decls[i] = decl;
- }
- else
- /* Otherwise, make one decl for each exception reason. */
- for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
- {
- char name[17];
-
- sprintf (name, "__gnat_rcheck_%.2d", i);
- gnat_raise_decls[i]
- = create_subprog_decl
- (get_identifier (name), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE,
- build_pointer_type
- (char_type_node),
- tree_cons (NULL_TREE,
- integer_type_node,
- endlink))),
- NULL_TREE, false, true, true, NULL, Empty);
- }
-
- /* Indicate that these never return. */
- TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
- TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
- TREE_TYPE (raise_nodefer_decl)
- = build_qualified_type (TREE_TYPE (raise_nodefer_decl),
- TYPE_QUAL_VOLATILE);
+ tree type_decl = build_decl (input_location,
+ TYPE_DECL, get_identifier (name), type);
- for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
- {
- TREE_THIS_VOLATILE (gnat_raise_decls[i]) = 1;
- TREE_SIDE_EFFECTS (gnat_raise_decls[i]) = 1;
- TREE_TYPE (gnat_raise_decls[i])
- = build_qualified_type (TREE_TYPE (gnat_raise_decls[i]),
- TYPE_QUAL_VOLATILE);
- }
+ gnat_pushdecl (type_decl, Empty);
- /* setjmp returns an integer and has one operand, which is a pointer to
- a jmpbuf. */
- setjmp_decl
- = create_subprog_decl
- (get_identifier ("__builtin_setjmp"), NULL_TREE,
- build_function_type (integer_type_node,
- tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
- DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
-
- /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
- address. */
- update_setjmp_buf_decl
- = create_subprog_decl
- (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
- build_function_type (void_type_node,
- tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
- NULL_TREE, false, true, true, NULL, Empty);
-
- DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
- DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
-
- main_identifier_node = get_identifier ("main");
-
- /* Install the builtins we might need, either internally or as
- user available facilities for Intrinsic imports. */
- gnat_install_builtins ();
+ if (debug_hooks->type_decl)
+ debug_hooks->type_decl (type_decl, false);
}
\f
-/* Given a record type RECORD_TYPE and a chain of FIELD_DECL nodes FIELDLIST,
+/* Given a record type RECORD_TYPE and a list of FIELD_DECL nodes FIELD_LIST,
finish constructing the record or union type. If REP_LEVEL is zero, this
record has no representation clause and so will be entirely laid out here.
If REP_LEVEL is one, this record has a representation clause and has been
laid out already; only set the sizes and alignment. If REP_LEVEL is two,
this record is derived from a parent record and thus inherits its layout;
- only make a pass on the fields to finalize them. If DO_NOT_FINALIZE is
- true, the record type is expected to be modified afterwards so it will
- not be sent to the back-end for finalization. */
+ only make a pass on the fields to finalize them. DEBUG_INFO_P is true if
+ we need to write debug information about this type. */
void
-finish_record_type (tree record_type, tree fieldlist, int rep_level,
- bool do_not_finalize)
+finish_record_type (tree record_type, tree field_list, int rep_level,
+ bool debug_info_p)
{
enum tree_code code = TREE_CODE (record_type);
tree name = TYPE_NAME (record_type);
bool had_align = TYPE_ALIGN (record_type) != 0;
tree field;
+ TYPE_FIELDS (record_type) = field_list;
+
+ /* Always attach the TYPE_STUB_DECL for a record type. It is required to
+ generate debug info and have a parallel type. */
if (name && TREE_CODE (name) == TYPE_DECL)
name = DECL_NAME (name);
-
- TYPE_FIELDS (record_type) = fieldlist;
- TYPE_STUB_DECL (record_type) = build_decl (TYPE_DECL, name, record_type);
-
- /* We don't need both the typedef name and the record name output in
- the debugging information, since they are the same. */
- DECL_ARTIFICIAL (TYPE_STUB_DECL (record_type)) = 1;
+ TYPE_STUB_DECL (record_type) = create_type_stub_decl (name, record_type);
/* Globally initialize the record first. If this is a rep'ed record,
that just means some initializations; otherwise, layout the record. */
if (rep_level > 0)
{
TYPE_ALIGN (record_type) = MAX (BITS_PER_UNIT, TYPE_ALIGN (record_type));
- TYPE_MODE (record_type) = BLKmode;
+ SET_TYPE_MODE (record_type, BLKmode);
if (!had_size_unit)
TYPE_SIZE_UNIT (record_type) = size_zero_node;
handled yet, and adjust DECL_NONADDRESSABLE_P accordingly. */
if (code == QUAL_UNION_TYPE)
- fieldlist = nreverse (fieldlist);
+ field_list = nreverse (field_list);
- for (field = fieldlist; field; field = TREE_CHAIN (field))
+ for (field = field_list; field; field = TREE_CHAIN (field))
{
tree type = TREE_TYPE (field);
tree pos = bit_position (field);
if ((TREE_CODE (type) == RECORD_TYPE
|| TREE_CODE (type) == UNION_TYPE
|| TREE_CODE (type) == QUAL_UNION_TYPE)
- && !TYPE_IS_FAT_POINTER_P (type)
+ && !TYPE_FAT_POINTER_P (type)
&& !TYPE_CONTAINS_TEMPLATE_P (type)
&& TYPE_ADA_SIZE (type))
this_ada_size = TYPE_ADA_SIZE (type);
DECL_BIT_FIELD (field) = 0;
}
- /* If we still have DECL_BIT_FIELD set at this point, we know the field
- is technically not addressable. Except that it can actually be
- addressed if the field is BLKmode and happens to be properly
- aligned. */
- DECL_NONADDRESSABLE_P (field)
- |= DECL_BIT_FIELD (field) && DECL_MODE (field) != BLKmode;
+ /* If we still have DECL_BIT_FIELD set at this point, we know that the
+ field is technically not addressable. Except that it can actually
+ be addressed if it is BLKmode and happens to be properly aligned. */
+ if (DECL_BIT_FIELD (field)
+ && !(DECL_MODE (field) == BLKmode
+ && value_factor_p (pos, BITS_PER_UNIT)))
+ DECL_NONADDRESSABLE_P (field) = 1;
/* A type must be as aligned as its most aligned field that is not
a bit-field. But this is already enforced by layout_type. */
}
if (code == QUAL_UNION_TYPE)
- nreverse (fieldlist);
+ nreverse (field_list);
if (rep_level < 2)
{
/* If this is a padding record, we never want to make the size smaller
than what was specified in it, if any. */
- if (TREE_CODE (record_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type))
+ if (TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type))
size = TYPE_SIZE (record_type);
/* Now set any of the values we've just computed that apply. */
- if (!TYPE_IS_FAT_POINTER_P (record_type)
+ if (!TYPE_FAT_POINTER_P (record_type)
&& !TYPE_CONTAINS_TEMPLATE_P (record_type))
SET_TYPE_ADA_SIZE (record_type, ada_size);
}
}
- if (!do_not_finalize)
+ if (debug_info_p)
rest_of_record_type_compilation (record_type);
}
-/* Wrap up compilation of RECORD_TYPE, i.e. most notably output all
- the debug information associated with it. It need not be invoked
- directly in most cases since finish_record_type takes care of doing
- so, unless explicitly requested not to through DO_NOT_FINALIZE. */
+/* Wrap up compilation of RECORD_TYPE, i.e. output all the debug information
+ associated with it. It need not be invoked directly in most cases since
+ finish_record_type takes care of doing so, but this can be necessary if
+ a parallel type is to be attached to the record type. */
void
rest_of_record_type_compilation (tree record_type)
{
- tree fieldlist = TYPE_FIELDS (record_type);
+ tree field_list = TYPE_FIELDS (record_type);
tree field;
enum tree_code code = TREE_CODE (record_type);
bool var_size = false;
- for (field = fieldlist; field; field = TREE_CHAIN (field))
+ for (field = field_list; field; field = TREE_CHAIN (field))
{
/* We need to make an XVE/XVU record if any field has variable size,
whether or not the record does. For example, if we have a union,
that tells the debugger how the record is laid out. See
exp_dbug.ads. But don't do this for records that are padding
since they confuse GDB. */
- if (var_size
- && !(TREE_CODE (record_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (record_type)))
+ if (var_size && !TYPE_IS_PADDING_P (record_type))
{
tree new_record_type
= make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE
? UNION_TYPE : TREE_CODE (record_type));
- tree orig_name = TYPE_NAME (record_type);
- tree orig_id
- = (TREE_CODE (orig_name) == TYPE_DECL ? DECL_NAME (orig_name)
- : orig_name);
- tree new_id
- = concat_id_with_name (orig_id,
- TREE_CODE (record_type) == QUAL_UNION_TYPE
- ? "XVU" : "XVE");
+ tree orig_name = TYPE_NAME (record_type), new_name;
tree last_pos = bitsize_zero_node;
- tree old_field;
- tree prev_old_field = 0;
+ tree old_field, prev_old_field = NULL_TREE;
+
+ if (TREE_CODE (orig_name) == TYPE_DECL)
+ orig_name = DECL_NAME (orig_name);
- TYPE_NAME (new_record_type) = new_id;
+ new_name
+ = concat_name (orig_name, TREE_CODE (record_type) == QUAL_UNION_TYPE
+ ? "XVU" : "XVE");
+ TYPE_NAME (new_record_type) = new_name;
TYPE_ALIGN (new_record_type) = BIGGEST_ALIGNMENT;
TYPE_STUB_DECL (new_record_type)
- = build_decl (TYPE_DECL, new_id, new_record_type);
- DECL_ARTIFICIAL (TYPE_STUB_DECL (new_record_type)) = 1;
+ = create_type_stub_decl (new_name, new_record_type);
DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type))
= DECL_IGNORED_P (TYPE_STUB_DECL (record_type));
TYPE_SIZE (new_record_type) = size_int (TYPE_ALIGN (record_type));
else
strcpy (suffix, "XVL");
- field_name = concat_id_with_name (field_name, suffix);
+ field_name = concat_name (field_name, suffix);
}
new_field = create_field_decl (field_name, field_type,
}
/* Utility function of above to merge LAST_SIZE, the previous size of a record
- with FIRST_BIT and SIZE that describe a field. SPECIAL is nonzero
- if this represents a QUAL_UNION_TYPE in which case we must look for
- COND_EXPRs and replace a value of zero with the old size. If HAS_REP
- is nonzero, we must take the MAX of the end position of this field
- with LAST_SIZE. In all other cases, we use FIRST_BIT plus SIZE.
-
- We return an expression for the size. */
+ with FIRST_BIT and SIZE that describe a field. SPECIAL is true if this
+ represents a QUAL_UNION_TYPE in which case we must look for COND_EXPRs and
+ replace a value of zero with the old size. If HAS_REP is true, we take the
+ MAX of the end position of this field with LAST_SIZE. In all other cases,
+ we use FIRST_BIT plus SIZE. Return an expression for the size. */
static tree
merge_sizes (tree last_size, tree first_bit, tree size, bool special,
bool has_rep)
{
tree type = TREE_TYPE (last_size);
- tree new;
+ tree new_size;
if (!special || TREE_CODE (size) != COND_EXPR)
{
- new = size_binop (PLUS_EXPR, first_bit, size);
+ new_size = size_binop (PLUS_EXPR, first_bit, size);
if (has_rep)
- new = size_binop (MAX_EXPR, last_size, new);
+ new_size = size_binop (MAX_EXPR, last_size, new_size);
}
else
- new = fold_build3 (COND_EXPR, type, TREE_OPERAND (size, 0),
- integer_zerop (TREE_OPERAND (size, 1))
- ? last_size : merge_sizes (last_size, first_bit,
- TREE_OPERAND (size, 1),
- 1, has_rep),
- integer_zerop (TREE_OPERAND (size, 2))
- ? last_size : merge_sizes (last_size, first_bit,
- TREE_OPERAND (size, 2),
- 1, has_rep));
+ new_size = fold_build3 (COND_EXPR, type, TREE_OPERAND (size, 0),
+ integer_zerop (TREE_OPERAND (size, 1))
+ ? last_size : merge_sizes (last_size, first_bit,
+ TREE_OPERAND (size, 1),
+ 1, has_rep),
+ integer_zerop (TREE_OPERAND (size, 2))
+ ? last_size : merge_sizes (last_size, first_bit,
+ TREE_OPERAND (size, 2),
+ 1, has_rep));
/* We don't need any NON_VALUE_EXPRs and they can confuse us (especially
when fed through substitute_in_expr) into thinking that a constant
size is not constant. */
- while (TREE_CODE (new) == NON_LVALUE_EXPR)
- new = TREE_OPERAND (new, 0);
+ while (TREE_CODE (new_size) == NON_LVALUE_EXPR)
+ new_size = TREE_OPERAND (new_size, 0);
- return new;
+ return new_size;
}
/* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are
tree
copy_type (tree type)
{
- tree new = copy_node (type);
+ tree new_type = copy_node (type);
+
+ /* Unshare the language-specific data. */
+ if (TYPE_LANG_SPECIFIC (type))
+ {
+ TYPE_LANG_SPECIFIC (new_type) = NULL;
+ SET_TYPE_LANG_SPECIFIC (new_type, GET_TYPE_LANG_SPECIFIC (type));
+ }
+
+ /* And the contents of the language-specific slot if needed. */
+ if ((INTEGRAL_TYPE_P (type) || TREE_CODE (type) == REAL_TYPE)
+ && TYPE_RM_VALUES (type))
+ {
+ TYPE_RM_VALUES (new_type) = NULL_TREE;
+ SET_TYPE_RM_SIZE (new_type, TYPE_RM_SIZE (type));
+ SET_TYPE_RM_MIN_VALUE (new_type, TYPE_RM_MIN_VALUE (type));
+ SET_TYPE_RM_MAX_VALUE (new_type, TYPE_RM_MAX_VALUE (type));
+ }
/* copy_node clears this field instead of copying it, because it is
aliased with TREE_CHAIN. */
- TYPE_STUB_DECL (new) = TYPE_STUB_DECL (type);
+ TYPE_STUB_DECL (new_type) = TYPE_STUB_DECL (type);
- TYPE_POINTER_TO (new) = 0;
- TYPE_REFERENCE_TO (new) = 0;
- TYPE_MAIN_VARIANT (new) = new;
- TYPE_NEXT_VARIANT (new) = 0;
+ TYPE_POINTER_TO (new_type) = 0;
+ TYPE_REFERENCE_TO (new_type) = 0;
+ TYPE_MAIN_VARIANT (new_type) = new_type;
+ TYPE_NEXT_VARIANT (new_type) = 0;
- return new;
+ return new_type;
}
\f
-/* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose
- TYPE_INDEX_TYPE is INDEX. GNAT_NODE is used for the position of
- the decl. */
+/* Return a subtype of sizetype with range MIN to MAX and whose
+ TYPE_INDEX_TYPE is INDEX. GNAT_NODE is used for the position
+ of the associated TYPE_DECL. */
tree
create_index_type (tree min, tree max, tree index, Node_Id gnat_node)
/* First build a type for the desired range. */
tree type = build_index_2_type (min, max);
- /* If this type has the TYPE_INDEX_TYPE we want, return it. Otherwise, if it
- doesn't have TYPE_INDEX_TYPE set, set it to INDEX. If TYPE_INDEX_TYPE
- is set, but not to INDEX, make a copy of this type with the requested
- index type. Note that we have no way of sharing these types, but that's
- only a small hole. */
+ /* If this type has the TYPE_INDEX_TYPE we want, return it. */
if (TYPE_INDEX_TYPE (type) == index)
return type;
- else if (TYPE_INDEX_TYPE (type))
+
+ /* Otherwise, if TYPE_INDEX_TYPE is set, make a copy. Note that we have
+ no way of sharing these types, but that's only a small hole. */
+ if (TYPE_INDEX_TYPE (type))
type = copy_type (type);
SET_TYPE_INDEX_TYPE (type, index);
create_type_decl (NULL_TREE, type, NULL, true, false, gnat_node);
+
return type;
}
+
+/* Return a subtype of TYPE with range MIN to MAX. If TYPE is NULL,
+ sizetype is used. */
+
+tree
+create_range_type (tree type, tree min, tree max)
+{
+ tree range_type;
+
+ if (type == NULL_TREE)
+ type = sizetype;
+
+ /* First build a type with the base range. */
+ range_type
+ = build_range_type (type, TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type));
+
+ min = convert (type, min);
+ max = convert (type, max);
+
+ /* If this type has the TYPE_RM_{MIN,MAX}_VALUE we want, return it. */
+ if (TYPE_RM_MIN_VALUE (range_type)
+ && TYPE_RM_MAX_VALUE (range_type)
+ && operand_equal_p (TYPE_RM_MIN_VALUE (range_type), min, 0)
+ && operand_equal_p (TYPE_RM_MAX_VALUE (range_type), max, 0))
+ return range_type;
+
+ /* Otherwise, if TYPE_RM_{MIN,MAX}_VALUE is set, make a copy. */
+ if (TYPE_RM_MIN_VALUE (range_type) || TYPE_RM_MAX_VALUE (range_type))
+ range_type = copy_type (range_type);
+
+ /* Then set the actual range. */
+ SET_TYPE_RM_MIN_VALUE (range_type, min);
+ SET_TYPE_RM_MAX_VALUE (range_type, max);
+
+ return range_type;
+}
\f
-/* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character
- string) and TYPE is a ..._TYPE node giving its data type.
- ARTIFICIAL_P is true if this is a declaration that was generated
- by the compiler. DEBUG_INFO_P is true if we need to write debugging
- information about this type. GNAT_NODE is used for the position of
- the decl. */
+/* Return a TYPE_DECL node suitable for the TYPE_STUB_DECL field of a type.
+ TYPE_NAME gives the name of the type and TYPE is a ..._TYPE node giving
+ its data type. */
+
+tree
+create_type_stub_decl (tree type_name, tree type)
+{
+ /* Using a named TYPE_DECL ensures that a type name marker is emitted in
+ STABS while setting DECL_ARTIFICIAL ensures that no DW_TAG_typedef is
+ emitted in DWARF. */
+ tree type_decl = build_decl (input_location,
+ TYPE_DECL, type_name, type);
+ DECL_ARTIFICIAL (type_decl) = 1;
+ return type_decl;
+}
+
+/* Return a TYPE_DECL node. TYPE_NAME gives the name of the type and TYPE
+ is a ..._TYPE node giving its data type. ARTIFICIAL_P is true if this
+ is a declaration that was generated by the compiler. DEBUG_INFO_P is
+ true if we need to write debug information about this type. GNAT_NODE
+ is used for the position of the decl. */
tree
create_type_decl (tree type_name, tree type, struct attrib *attr_list,
bool artificial_p, bool debug_info_p, Node_Id gnat_node)
{
- tree type_decl = build_decl (TYPE_DECL, type_name, type);
enum tree_code code = TREE_CODE (type);
+ bool named = TYPE_NAME (type) && TREE_CODE (TYPE_NAME (type)) == TYPE_DECL;
+ tree type_decl;
- DECL_ARTIFICIAL (type_decl) = artificial_p;
+ /* Only the builtin TYPE_STUB_DECL should be used for dummy types. */
+ gcc_assert (!TYPE_IS_DUMMY_P (type));
- if (!TYPE_IS_DUMMY_P (type))
- gnat_pushdecl (type_decl, gnat_node);
+ /* If the type hasn't been named yet, we're naming it; preserve an existing
+ TYPE_STUB_DECL that has been attached to it for some purpose. */
+ if (!named && TYPE_STUB_DECL (type))
+ {
+ type_decl = TYPE_STUB_DECL (type);
+ DECL_NAME (type_decl) = type_name;
+ }
+ else
+ type_decl = build_decl (input_location,
+ TYPE_DECL, type_name, type);
+ DECL_ARTIFICIAL (type_decl) = artificial_p;
+ gnat_pushdecl (type_decl, gnat_node);
process_attributes (type_decl, attr_list);
- /* Pass type declaration information to the debugger unless this is an
- UNCONSTRAINED_ARRAY_TYPE, which the debugger does not support,
- and ENUMERAL_TYPE or RECORD_TYPE which is handled separately, or
- type for which debugging information was not requested. */
+ /* If we're naming the type, equate the TYPE_STUB_DECL to the name.
+ This causes the name to be also viewed as a "tag" by the debug
+ back-end, with the advantage that no DW_TAG_typedef is emitted
+ for artificial "tagged" types in DWARF. */
+ if (!named)
+ TYPE_STUB_DECL (type) = type_decl;
+
+ /* Pass the type declaration to the debug back-end unless this is an
+ UNCONSTRAINED_ARRAY_TYPE that the back-end does not support, or a
+ type for which debugging information was not requested, or else an
+ ENUMERAL_TYPE or RECORD_TYPE (except for fat pointers) which are
+ handled separately. And do not pass dummy types either. */
if (code == UNCONSTRAINED_ARRAY_TYPE || !debug_info_p)
DECL_IGNORED_P (type_decl) = 1;
else if (code != ENUMERAL_TYPE
- && (code != RECORD_TYPE || TYPE_IS_FAT_POINTER_P (type))
+ && (code != RECORD_TYPE || TYPE_FAT_POINTER_P (type))
&& !((code == POINTER_TYPE || code == REFERENCE_TYPE)
- && TYPE_IS_DUMMY_P (TREE_TYPE (type))))
+ && TYPE_IS_DUMMY_P (TREE_TYPE (type)))
+ && !(code == RECORD_TYPE
+ && TYPE_IS_DUMMY_P
+ (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (type))))))
rest_of_type_decl_compilation (type_decl);
return type_decl;
}
-
+\f
/* Return a VAR_DECL or CONST_DECL node.
VAR_NAME gives the name of the variable. ASM_NAME is its assembler name
definition to be made visible outside of the current compilation unit, for
instance variable definitions in a package specification.
- EXTERN_FLAG is nonzero when processing an external variable declaration (as
+ EXTERN_FLAG is true when processing an external variable declaration (as
opposed to a definition: no storage is to be allocated for the variable).
STATIC_FLAG is only relevant when not at top level. In that case
/* The actual DECL node. CONST_DECL was initially intended for enumerals
and may be used for scalars in general but not for aggregates. */
tree var_decl
- = build_decl ((constant_p && const_decl_allowed_p
+ = build_decl (input_location,
+ (constant_p && const_decl_allowed_p
&& !AGGREGATE_TYPE_P (type)) ? CONST_DECL : VAR_DECL,
var_name, type);
that is, not violating a No_Elaboration_Code restriction. */
if (global_bindings_p () && var_init != 0 && ! init_const)
Check_Elaboration_Code_Allowed (gnat_node);
+ DECL_INITIAL (var_decl) = var_init;
+ TREE_READONLY (var_decl) = const_flag;
+ DECL_EXTERNAL (var_decl) = extern_flag;
+ TREE_PUBLIC (var_decl) = public_flag || extern_flag;
+ TREE_CONSTANT (var_decl) = constant_p;
+ TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl)
+ = TYPE_VOLATILE (type);
/* Ada doesn't feature Fortran-like COMMON variables so we shouldn't
try to fiddle with DECL_COMMON. However, on platforms that don't
go in DATA instead, thus increasing the size of the executable. */
if (!flag_no_common
&& TREE_CODE (var_decl) == VAR_DECL
+ && TREE_PUBLIC (var_decl)
&& !have_global_bss_p ())
DECL_COMMON (var_decl) = 1;
- DECL_INITIAL (var_decl) = var_init;
- TREE_READONLY (var_decl) = const_flag;
- DECL_EXTERNAL (var_decl) = extern_flag;
- TREE_PUBLIC (var_decl) = public_flag || extern_flag;
- TREE_CONSTANT (var_decl) = constant_p;
- TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl)
- = TYPE_VOLATILE (type);
/* If it's public and not external, always allocate storage for it.
At the global binding level we need to allocate static storage for the
TREE_STATIC (var_decl)
= !extern_flag && (public_flag || static_flag || global_bindings_p ());
- if (asm_name && VAR_OR_FUNCTION_DECL_P (var_decl))
- SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
+ /* For an external constant whose initializer is not absolute, do not emit
+ debug info. In DWARF this would mean a global relocation in a read-only
+ section which runs afoul of the PE-COFF runtime relocation mechanism. */
+ if (extern_flag
+ && constant_p
+ && initializer_constant_valid_p (var_init, TREE_TYPE (var_init))
+ != null_pointer_node)
+ DECL_IGNORED_P (var_decl) = 1;
- process_attributes (var_decl, attr_list);
+ if (TREE_CODE (var_decl) == VAR_DECL)
+ {
+ if (asm_name)
+ SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
+ process_attributes (var_decl, attr_list);
+ }
/* Add this decl to the current binding level. */
gnat_pushdecl (var_decl, gnat_node);
}
}
-/* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its
- type, and RECORD_TYPE is the type of the parent. PACKED is nonzero if
- this field is in a record type with a "pragma pack". If SIZE is nonzero
- it is the specified size for this field. If POS is nonzero, it is the bit
- position. If ADDRESSABLE is nonzero, it means we are allowed to take
- the address of this field for aliasing purposes. If it is negative, we
- should not make a bitfield, which is used by make_aligning_type. */
+/* Return a FIELD_DECL node. FIELD_NAME is the field's name, FIELD_TYPE is
+ its type and RECORD_TYPE is the type of the enclosing record. PACKED is
+ 1 if the enclosing record is packed, -1 if it has Component_Alignment of
+ Storage_Unit. If SIZE is nonzero, it is the specified size of the field.
+ If POS is nonzero, it is the bit position. If ADDRESSABLE is nonzero, it
+ means we are allowed to take the address of the field; if it is negative,
+ we should not make a bitfield, which is used by make_aligning_type. */
tree
create_field_decl (tree field_name, tree field_type, tree record_type,
int packed, tree size, tree pos, int addressable)
{
- tree field_decl = build_decl (FIELD_DECL, field_name, field_type);
+ tree field_decl = build_decl (input_location,
+ FIELD_DECL, field_name, field_type);
DECL_CONTEXT (field_decl) = record_type;
TREE_READONLY (field_decl) = TYPE_READONLY (field_type);
else if (packed == 1)
{
size = rm_size (field_type);
-
- /* For a constant size larger than MAX_FIXED_MODE_SIZE, round up to
- byte. */
- if (TREE_CODE (size) == INTEGER_CST
- && compare_tree_int (size, MAX_FIXED_MODE_SIZE) > 0)
- size = round_up (size, BITS_PER_UNIT);
+ if (TYPE_MODE (field_type) == BLKmode)
+ size = round_up (size, BITS_PER_UNIT);
}
/* If we may, according to ADDRESSABLE, make a bitfield if a size is
DECL_BIT_FIELD (field_decl) = 1;
DECL_SIZE (field_decl) = size;
if (!packed && !pos)
- DECL_ALIGN (field_decl)
- = (TYPE_ALIGN (record_type) != 0
- ? MIN (TYPE_ALIGN (record_type), TYPE_ALIGN (field_type))
- : TYPE_ALIGN (field_type));
+ {
+ if (TYPE_ALIGN (record_type) != 0
+ && TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type))
+ DECL_ALIGN (field_decl) = TYPE_ALIGN (record_type);
+ else
+ DECL_ALIGN (field_decl) = TYPE_ALIGN (field_type);
+ }
}
DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed;
we get the alignment from the type, indicate if this is from an explicit
user request, which prevents stor-layout from lowering it later on. */
{
- int bit_align
+ unsigned int bit_align
= (DECL_BIT_FIELD (field_decl) ? 1
: packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT : 0);
pos_from_bit (&DECL_FIELD_OFFSET (field_decl),
&DECL_FIELD_BIT_OFFSET (field_decl),
DECL_OFFSET_ALIGN (field_decl), pos);
-
- DECL_HAS_REP_P (field_decl) = 1;
}
/* In addition to what our caller says, claim the field is addressable if we
of a copy. This is the case for true bitfields, but the DECL_BIT_FIELD
value we have at this point is not accurate enough, so we don't account
for this here and let finish_record_type decide. */
- if (!type_for_nonaliased_component_p (field_type))
+ if (!addressable && !type_for_nonaliased_component_p (field_type))
addressable = 1;
DECL_NONADDRESSABLE_P (field_decl) = !addressable;
return field_decl;
}
\f
-/* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter,
- PARAM_TYPE is its type. READONLY is true if the parameter is
- readonly (either an In parameter or an address of a pass-by-ref
- parameter). */
+/* Return a PARM_DECL node. PARAM_NAME is the name of the parameter and
+ PARAM_TYPE is its type. READONLY is true if the parameter is readonly
+ (either an In parameter or an address of a pass-by-ref parameter). */
tree
create_param_decl (tree param_name, tree param_type, bool readonly)
{
- tree param_decl = build_decl (PARM_DECL, param_name, param_type);
-
- /* Honor targetm.calls.promote_prototypes(), as not doing so can
- lead to various ABI violations. */
- if (targetm.calls.promote_prototypes (param_type)
- && (TREE_CODE (param_type) == INTEGER_TYPE
- || TREE_CODE (param_type) == ENUMERAL_TYPE
- || TREE_CODE (param_type) == BOOLEAN_TYPE)
+ tree param_decl = build_decl (input_location,
+ PARM_DECL, param_name, param_type);
+
+ /* Honor TARGET_PROMOTE_PROTOTYPES like the C compiler, as not doing so
+ can lead to various ABI violations. */
+ if (targetm.calls.promote_prototypes (NULL_TREE)
+ && INTEGRAL_TYPE_P (param_type)
&& TYPE_PRECISION (param_type) < TYPE_PRECISION (integer_type_node))
{
/* We have to be careful about biased types here. Make a subtype
if (TREE_CODE (param_type) == INTEGER_TYPE
&& TYPE_BIASED_REPRESENTATION_P (param_type))
{
- param_type
- = copy_type (build_range_type (integer_type_node,
- TYPE_MIN_VALUE (param_type),
- TYPE_MAX_VALUE (param_type)));
-
- TYPE_BIASED_REPRESENTATION_P (param_type) = 1;
+ tree subtype
+ = make_unsigned_type (TYPE_PRECISION (integer_type_node));
+ TREE_TYPE (subtype) = integer_type_node;
+ TYPE_BIASED_REPRESENTATION_P (subtype) = 1;
+ SET_TYPE_RM_MIN_VALUE (subtype, TYPE_MIN_VALUE (param_type));
+ SET_TYPE_RM_MAX_VALUE (subtype, TYPE_MAX_VALUE (param_type));
+ param_type = subtype;
}
else
param_type = integer_type_node;
DECL_STATIC_DESTRUCTOR (decl) = 1;
TREE_USED (decl) = 1;
break;
+
+ case ATTR_THREAD_LOCAL_STORAGE:
+ DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
+ DECL_COMMON (decl) = 0;
+ break;
}
}
\f
-/* Record a global renaming pointer. */
+/* Record DECL as a global renaming pointer. */
void
record_global_renaming_pointer (tree decl)
tree
create_label_decl (tree label_name)
{
- tree label_decl = build_decl (LABEL_DECL, label_name, void_type_node);
+ tree label_decl = build_decl (input_location,
+ LABEL_DECL, label_name, void_type_node);
DECL_CONTEXT (label_decl) = current_function_decl;
DECL_MODE (label_decl) = VOIDmode;
struct attrib *attr_list, Node_Id gnat_node)
{
tree return_type = TREE_TYPE (subprog_type);
- tree subprog_decl = build_decl (FUNCTION_DECL, subprog_name, subprog_type);
-
- /* If this is a function nested inside an inlined external function, it
- means we aren't going to compile the outer function unless it is
- actually inlined, so do the same for us. */
- if (current_function_decl && DECL_INLINE (current_function_decl)
+ tree subprog_decl = build_decl (input_location,
+ FUNCTION_DECL, subprog_name, subprog_type);
+
+ /* If this is a non-inline function nested inside an inlined external
+ function, we cannot honor both requests without cloning the nested
+ function in the current unit since it is private to the other unit.
+ We could inline the nested function as well but it's probably better
+ to err on the side of too little inlining. */
+ if (!inline_flag
+ && current_function_decl
+ && DECL_DECLARED_INLINE_P (current_function_decl)
&& DECL_EXTERNAL (current_function_decl))
- extern_flag = true;
+ DECL_DECLARED_INLINE_P (current_function_decl) = 0;
DECL_EXTERNAL (subprog_decl) = extern_flag;
TREE_PUBLIC (subprog_decl) = public_flag;
TREE_READONLY (subprog_decl) = TYPE_READONLY (subprog_type);
TREE_THIS_VOLATILE (subprog_decl) = TYPE_VOLATILE (subprog_type);
TREE_SIDE_EFFECTS (subprog_decl) = TYPE_VOLATILE (subprog_type);
+ DECL_DECLARED_INLINE_P (subprog_decl) = inline_flag;
DECL_ARGUMENTS (subprog_decl) = param_decl_list;
- DECL_RESULT (subprog_decl) = build_decl (RESULT_DECL, 0, return_type);
+ DECL_RESULT (subprog_decl) = build_decl (input_location,
+ RESULT_DECL, 0, return_type);
DECL_ARTIFICIAL (DECL_RESULT (subprog_decl)) = 1;
DECL_IGNORED_P (DECL_RESULT (subprog_decl)) = 1;
DECL_BY_REFERENCE (result_decl) = 1;
}
- if (inline_flag)
- DECL_DECLARED_INLINE_P (subprog_decl) = 1;
-
if (asm_name)
{
SET_DECL_ASSEMBLER_NAME (subprog_decl, asm_name);
to be declared as the "main" function literally by default. Ada
program entry points are typically declared with a different name
within the binder generated file, exported as 'main' to satisfy the
- system expectations. Redirect main_identifier_node in this case. */
+ system expectations. Force main_identifier_node in this case. */
if (asm_name == main_identifier_node)
- main_identifier_node = DECL_NAME (subprog_decl);
+ DECL_NAME (subprog_decl) = main_identifier_node;
}
process_attributes (subprog_decl, attr_list);
pointer_set_destroy (p_set);
}
-/* Finish the definition of the current subprogram BODY and compile it all the
- way to assembler language output. ELAB_P tells if this is called for an
- elaboration routine, to be entirely discarded if empty. */
+/* Finish the definition of the current subprogram BODY and finalize it. */
void
-end_subprog_body (tree body, bool elab_p)
+end_subprog_body (tree body)
{
tree fndecl = current_function_decl;
DECL_INITIAL (fndecl) = current_binding_level->block;
gnat_poplevel ();
- /* Deal with inline. If declared inline or we should default to inline,
- set the flag in the decl. */
- DECL_INLINE (fndecl) = 1;
-
/* We handle pending sizes via the elaboration of types, so we don't
need to save them. */
get_pending_sizes ();
/* Perform the required pre-gimplification transformations on the tree. */
gnat_genericize (fndecl);
- /* We do different things for nested and non-nested functions.
- ??? This should be in cgraph. */
- if (!DECL_CONTEXT (fndecl))
- {
- gnat_gimplify_function (fndecl);
+ /* Dump functions before gimplification. */
+ dump_function (TDI_original, fndecl);
- /* If this is an empty elaboration proc, just discard the node.
- Otherwise, compile further. */
- if (elab_p && empty_body_p (gimple_body (fndecl)))
- cgraph_remove_node (cgraph_node (fndecl));
- else
- cgraph_finalize_function (fndecl, false);
- }
+ /* ??? This special handling of nested functions is probably obsolete. */
+ if (!DECL_CONTEXT (fndecl))
+ cgraph_finalize_function (fndecl, false);
else
/* Register this function with cgraph just far enough to get it
added to our parent's nested function list. */
(void) cgraph_node (fndecl);
}
-/* Convert FNDECL's code to GIMPLE and handle any nested functions. */
-
-static void
-gnat_gimplify_function (tree fndecl)
-{
- struct cgraph_node *cgn;
-
- dump_function (TDI_original, fndecl);
- gimplify_function_tree (fndecl);
- dump_function (TDI_generic, fndecl);
-
- /* Convert all nested functions to GIMPLE now. We do things in this order
- so that items like VLA sizes are expanded properly in the context of the
- correct function. */
- cgn = cgraph_node (fndecl);
- for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
- gnat_gimplify_function (cgn->decl);
-}
-\f
-
tree
gnat_builtin_function (tree decl)
{
{
if (mode == BLKmode)
return NULL_TREE;
- else if (mode == VOIDmode)
+
+ if (mode == VOIDmode)
return void_type_node;
- else if (COMPLEX_MODE_P (mode))
+
+ if (COMPLEX_MODE_P (mode))
return NULL_TREE;
- else if (SCALAR_FLOAT_MODE_P (mode))
+
+ if (SCALAR_FLOAT_MODE_P (mode))
return float_type_for_precision (GET_MODE_PRECISION (mode), mode);
- else if (SCALAR_INT_MODE_P (mode))
+
+ if (SCALAR_INT_MODE_P (mode))
return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
- else
- return NULL_TREE;
+
+ if (VECTOR_MODE_P (mode))
+ {
+ enum machine_mode inner_mode = GET_MODE_INNER (mode);
+ tree inner_type = gnat_type_for_mode (inner_mode, unsignedp);
+ if (inner_type)
+ return build_vector_type_for_mode (inner_type, mode);
+ }
+
+ return NULL_TREE;
}
/* Return the unsigned version of a TYPE_NODE, a scalar type. */
if ((code = TREE_CODE (t1)) != TREE_CODE (t2))
return 0;
+ /* Vector types are also compatible if they have the same number of subparts
+ and the same form of (scalar) element type. */
+ if (code == VECTOR_TYPE
+ && TYPE_VECTOR_SUBPARTS (t1) == TYPE_VECTOR_SUBPARTS (t2)
+ && TREE_CODE (TREE_TYPE (t1)) == TREE_CODE (TREE_TYPE (t2))
+ && TYPE_PRECISION (TREE_TYPE (t1)) == TYPE_PRECISION (TREE_TYPE (t2)))
+ return 1;
+
/* Array types are also compatible if they are constrained and have
the same component type and the same domain. */
if (code == ARRAY_TYPE
&& TREE_TYPE (t1) == TREE_TYPE (t2)
- && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (t1)),
- TYPE_MIN_VALUE (TYPE_DOMAIN (t2)))
- && tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (t1)),
- TYPE_MAX_VALUE (TYPE_DOMAIN (t2))))
+ && (TYPE_DOMAIN (t1) == TYPE_DOMAIN (t2)
+ || (TYPE_DOMAIN (t1)
+ && TYPE_DOMAIN (t2)
+ && tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (t1)),
+ TYPE_MIN_VALUE (TYPE_DOMAIN (t2)))
+ && tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (t1)),
+ TYPE_MAX_VALUE (TYPE_DOMAIN (t2))))))
return 1;
/* Padding record types are also compatible if they pad the same
type and have the same constant size. */
if (code == RECORD_TYPE
- && TYPE_IS_PADDING_P (t1) && TYPE_IS_PADDING_P (t2)
+ && TYPE_PADDING_P (t1) && TYPE_PADDING_P (t2)
&& TREE_TYPE (TYPE_FIELDS (t1)) == TREE_TYPE (TYPE_FIELDS (t2))
&& tree_int_cst_equal (TYPE_SIZE (t1), TYPE_SIZE (t2)))
return 1;
case tcc_vl_exp:
if (code == CALL_EXPR)
{
- tree *argarray;
- int i, n = call_expr_nargs (exp);
- gcc_assert (n > 0);
+ tree t, *argarray;
+ int n, i;
+ t = maybe_inline_call_in_expr (exp);
+ if (t)
+ return max_size (t, max_p);
+
+ n = call_expr_nargs (exp);
+ gcc_assert (n > 0);
argarray = (tree *) alloca (n * sizeof (tree));
for (i = 0; i < n; i++)
argarray[i] = max_size (CALL_EXPR_ARG (exp, i), max_p);
tree field;
while (TREE_CODE (array_type) == RECORD_TYPE
- && (TYPE_IS_PADDING_P (array_type)
+ && (TYPE_PADDING_P (array_type)
|| TYPE_JUSTIFIED_MODULAR_P (array_type)))
array_type = TREE_TYPE (TYPE_FIELDS (array_type));
an object of that type and also for the name. */
tree
-build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
+build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
{
tree record_type = make_node (RECORD_TYPE);
tree pointer32_type;
tree field_list = 0;
- int class;
+ int klass;
int dtype = 0;
tree inner_type;
int ndim;
idx_arr = (tree *) alloca (ndim * sizeof (tree));
- if (mech != By_Descriptor_NCA
+ if (mech != By_Descriptor_NCA && mech != By_Short_Descriptor_NCA
&& TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
for (i = ndim - 1, inner_type = type;
i >= 0;
switch (mech)
{
case By_Descriptor_A:
- class = 4;
+ case By_Short_Descriptor_A:
+ klass = 4;
break;
case By_Descriptor_NCA:
- class = 10;
+ case By_Short_Descriptor_NCA:
+ klass = 10;
break;
case By_Descriptor_SB:
- class = 15;
+ case By_Short_Descriptor_SB:
+ klass = 15;
break;
case By_Descriptor:
+ case By_Short_Descriptor:
case By_Descriptor_S:
+ case By_Short_Descriptor_S:
default:
- class = 1;
+ klass = 1;
break;
}
= chainon (field_list,
make_descriptor_field
("LENGTH", gnat_type_for_size (16, 1), record_type,
- size_in_bytes (mech == By_Descriptor_A ? inner_type : type)));
+ size_in_bytes ((mech == By_Descriptor_A ||
+ mech == By_Short_Descriptor_A)
+ ? inner_type : type)));
field_list = chainon (field_list,
make_descriptor_field ("DTYPE",
field_list = chainon (field_list,
make_descriptor_field ("CLASS",
gnat_type_for_size (8, 1),
- record_type, size_int (class)));
+ record_type, size_int (klass)));
/* Of course this will crash at run-time if the address space is not
within the low 32 bits, but there is nothing else we can do. */
switch (mech)
{
case By_Descriptor:
+ case By_Short_Descriptor:
case By_Descriptor_S:
+ case By_Short_Descriptor_S:
break;
case By_Descriptor_SB:
+ case By_Short_Descriptor_SB:
field_list
= chainon (field_list,
make_descriptor_field
break;
case By_Descriptor_A:
+ case By_Short_Descriptor_A:
case By_Descriptor_NCA:
+ case By_Short_Descriptor_NCA:
field_list = chainon (field_list,
make_descriptor_field ("SCALE",
gnat_type_for_size (8, 1),
= chainon (field_list,
make_descriptor_field
("AFLAGS", gnat_type_for_size (8, 1), record_type,
- size_int (mech == By_Descriptor_NCA
+ size_int ((mech == By_Descriptor_NCA ||
+ mech == By_Short_Descriptor_NCA)
? 0
/* Set FL_COLUMN, FL_COEFF, and FL_BOUNDS. */
: (TREE_CODE (type) == ARRAY_TYPE
TYPE_MIN_VALUE (idx_arr[i])),
size_int (1)));
- fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M');
+ fname[0] = ((mech == By_Descriptor_NCA ||
+ mech == By_Short_Descriptor_NCA) ? 'S' : 'M');
fname[1] = '0' + i, fname[2] = 0;
field_list
= chainon (field_list,
gnat_type_for_size (32, 1),
record_type, idx_length));
- if (mech == By_Descriptor_NCA)
+ if (mech == By_Descriptor_NCA || mech == By_Short_Descriptor_NCA)
tem = idx_length;
}
post_error ("unsupported descriptor type for &", gnat_entity);
}
- finish_record_type (record_type, field_list, 0, true);
- create_type_decl (create_concat_name (gnat_entity, "DESC"), record_type,
- NULL, true, false, gnat_entity);
-
+ TYPE_NAME (record_type) = create_concat_name (gnat_entity, "DESC");
+ finish_record_type (record_type, field_list, 0, false);
return record_type;
}
an object of that type and also for the name. */
tree
-build_vms_descriptor64 (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
+build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
{
tree record64_type = make_node (RECORD_TYPE);
tree pointer64_type;
tree field_list64 = 0;
- int class;
+ int klass;
int dtype = 0;
tree inner_type;
int ndim;
switch (mech)
{
case By_Descriptor_A:
- class = 4;
+ klass = 4;
break;
case By_Descriptor_NCA:
- class = 10;
+ klass = 10;
break;
case By_Descriptor_SB:
- class = 15;
+ klass = 15;
break;
case By_Descriptor:
case By_Descriptor_S:
default:
- class = 1;
+ klass = 1;
break;
}
field_list64 = chainon (field_list64,
make_descriptor_field ("CLASS",
gnat_type_for_size (8, 1),
- record64_type, size_int (class)));
+ record64_type, size_int (klass)));
field_list64 = chainon (field_list64,
make_descriptor_field ("MBMO",
post_error ("unsupported descriptor type for &", gnat_entity);
}
- finish_record_type (record64_type, field_list64, 0, true);
- create_type_decl (create_concat_name (gnat_entity, "DESC64"), record64_type,
- NULL, true, false, gnat_entity);
-
+ TYPE_NAME (record64_type) = create_concat_name (gnat_entity, "DESC64");
+ finish_record_type (record64_type, field_list64, 0, false);
return record64_type;
}
return field;
}
-/* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular
- pointer or fat pointer type. GNAT_SUBPROG is the subprogram to which
- the VMS descriptor is passed. */
+/* Convert GNU_EXPR, a pointer to a 64bit VMS descriptor, to GNU_TYPE, a
+ regular pointer or fat pointer type. GNAT_SUBPROG is the subprogram to
+ which the VMS descriptor is passed. */
+
+static tree
+convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
+{
+ tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
+ tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
+ /* The CLASS field is the 3rd field in the descriptor. */
+ tree klass = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (desc_type)));
+ /* The POINTER field is the 6th field in the descriptor. */
+ tree pointer64 = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (klass)));
+
+ /* Retrieve the value of the POINTER field. */
+ tree gnu_expr64
+ = build3 (COMPONENT_REF, TREE_TYPE (pointer64), desc, pointer64, NULL_TREE);
+
+ if (POINTER_TYPE_P (gnu_type))
+ return convert (gnu_type, gnu_expr64);
+
+ else if (TYPE_IS_FAT_POINTER_P (gnu_type))
+ {
+ tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
+ tree p_bounds_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
+ tree template_type = TREE_TYPE (p_bounds_type);
+ tree min_field = TYPE_FIELDS (template_type);
+ tree max_field = TREE_CHAIN (TYPE_FIELDS (template_type));
+ tree template_tree, template_addr, aflags, dimct, t, u;
+ /* See the head comment of build_vms_descriptor. */
+ int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass));
+ tree lfield, ufield;
+
+ /* Convert POINTER to the type of the P_ARRAY field. */
+ gnu_expr64 = convert (p_array_type, gnu_expr64);
+
+ switch (iklass)
+ {
+ case 1: /* Class S */
+ case 15: /* Class SB */
+ /* Build {1, LENGTH} template; LENGTH64 is the 5th field. */
+ t = TREE_CHAIN (TREE_CHAIN (klass));
+ t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+ t = tree_cons (min_field,
+ convert (TREE_TYPE (min_field), integer_one_node),
+ tree_cons (max_field,
+ convert (TREE_TYPE (max_field), t),
+ NULL_TREE));
+ template_tree = gnat_build_constructor (template_type, t);
+ template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_tree);
+
+ /* For class S, we are done. */
+ if (iklass == 1)
+ break;
+
+ /* Test that we really have a SB descriptor, like DEC Ada. */
+ t = build3 (COMPONENT_REF, TREE_TYPE (klass), desc, klass, NULL);
+ u = convert (TREE_TYPE (klass), DECL_INITIAL (klass));
+ u = build_binary_op (EQ_EXPR, integer_type_node, t, u);
+ /* If so, there is already a template in the descriptor and
+ it is located right after the POINTER field. The fields are
+ 64bits so they must be repacked. */
+ t = TREE_CHAIN (pointer64);
+ lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+ lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield);
+
+ t = TREE_CHAIN (t);
+ ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+ ufield = convert
+ (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (template_type))), ufield);
+
+ /* Build the template in the form of a constructor. */
+ t = tree_cons (TYPE_FIELDS (template_type), lfield,
+ tree_cons (TREE_CHAIN (TYPE_FIELDS (template_type)),
+ ufield, NULL_TREE));
+ template_tree = gnat_build_constructor (template_type, t);
+
+ /* Otherwise use the {1, LENGTH} template we build above. */
+ template_addr = build3 (COND_EXPR, p_bounds_type, u,
+ build_unary_op (ADDR_EXPR, p_bounds_type,
+ template_tree),
+ template_addr);
+ break;
+
+ case 4: /* Class A */
+ /* The AFLAGS field is the 3rd field after the pointer in the
+ descriptor. */
+ t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (pointer64)));
+ aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+ /* The DIMCT field is the next field in the descriptor after
+ aflags. */
+ t = TREE_CHAIN (t);
+ dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+ /* Raise CONSTRAINT_ERROR if either more than 1 dimension
+ or FL_COEFF or FL_BOUNDS not set. */
+ u = build_int_cst (TREE_TYPE (aflags), 192);
+ u = build_binary_op (TRUTH_OR_EXPR, integer_type_node,
+ build_binary_op (NE_EXPR, integer_type_node,
+ dimct,
+ convert (TREE_TYPE (dimct),
+ size_one_node)),
+ build_binary_op (NE_EXPR, integer_type_node,
+ build2 (BIT_AND_EXPR,
+ TREE_TYPE (aflags),
+ aflags, u),
+ u));
+ /* There is already a template in the descriptor and it is located
+ in block 3. The fields are 64bits so they must be repacked. */
+ t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN
+ (t)))));
+ lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+ lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield);
+
+ t = TREE_CHAIN (t);
+ ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+ ufield = convert
+ (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (template_type))), ufield);
+
+ /* Build the template in the form of a constructor. */
+ t = tree_cons (TYPE_FIELDS (template_type), lfield,
+ tree_cons (TREE_CHAIN (TYPE_FIELDS (template_type)),
+ ufield, NULL_TREE));
+ template_tree = gnat_build_constructor (template_type, t);
+ template_tree = build3 (COND_EXPR, template_type, u,
+ build_call_raise (CE_Length_Check_Failed, Empty,
+ N_Raise_Constraint_Error),
+ template_tree);
+ template_addr
+ = build_unary_op (ADDR_EXPR, p_bounds_type, template_tree);
+ break;
+
+ case 10: /* Class NCA */
+ default:
+ post_error ("unsupported descriptor type for &", gnat_subprog);
+ template_addr = integer_zero_node;
+ break;
+ }
+
+ /* Build the fat pointer in the form of a constructor. */
+ t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr64,
+ tree_cons (TREE_CHAIN (TYPE_FIELDS (gnu_type)),
+ template_addr, NULL_TREE));
+ return gnat_build_constructor (gnu_type, t);
+ }
+
+ else
+ gcc_unreachable ();
+}
+
+/* Convert GNU_EXPR, a pointer to a 32bit VMS descriptor, to GNU_TYPE, a
+ regular pointer or fat pointer type. GNAT_SUBPROG is the subprogram to
+ which the VMS descriptor is passed. */
static tree
-convert_vms_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
+convert_vms_descriptor32 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
{
tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
/* The CLASS field is the 3rd field in the descriptor. */
- tree class = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (desc_type)));
+ tree klass = TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (desc_type)));
/* The POINTER field is the 4th field in the descriptor. */
- tree pointer = TREE_CHAIN (class);
+ tree pointer = TREE_CHAIN (klass);
/* Retrieve the value of the POINTER field. */
- gnu_expr
+ tree gnu_expr32
= build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE);
if (POINTER_TYPE_P (gnu_type))
- return convert (gnu_type, gnu_expr);
+ return convert (gnu_type, gnu_expr32);
- else if (TYPE_FAT_POINTER_P (gnu_type))
+ else if (TYPE_IS_FAT_POINTER_P (gnu_type))
{
tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
tree p_bounds_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)));
tree template_type = TREE_TYPE (p_bounds_type);
tree min_field = TYPE_FIELDS (template_type);
tree max_field = TREE_CHAIN (TYPE_FIELDS (template_type));
- tree template, template_addr, aflags, dimct, t, u;
+ tree template_tree, template_addr, aflags, dimct, t, u;
/* See the head comment of build_vms_descriptor. */
- int iclass = TREE_INT_CST_LOW (DECL_INITIAL (class));
+ int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass));
/* Convert POINTER to the type of the P_ARRAY field. */
- gnu_expr = convert (p_array_type, gnu_expr);
+ gnu_expr32 = convert (p_array_type, gnu_expr32);
- switch (iclass)
+ switch (iklass)
{
case 1: /* Class S */
case 15: /* Class SB */
tree_cons (max_field,
convert (TREE_TYPE (max_field), t),
NULL_TREE));
- template = gnat_build_constructor (template_type, t);
- template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template);
+ template_tree = gnat_build_constructor (template_type, t);
+ template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_tree);
/* For class S, we are done. */
- if (iclass == 1)
+ if (iklass == 1)
break;
/* Test that we really have a SB descriptor, like DEC Ada. */
- t = build3 (COMPONENT_REF, TREE_TYPE (class), desc, class, NULL);
- u = convert (TREE_TYPE (class), DECL_INITIAL (class));
+ t = build3 (COMPONENT_REF, TREE_TYPE (klass), desc, klass, NULL);
+ u = convert (TREE_TYPE (klass), DECL_INITIAL (klass));
u = build_binary_op (EQ_EXPR, integer_type_node, t, u);
/* If so, there is already a template in the descriptor and
it is located right after the POINTER field. */
t = TREE_CHAIN (pointer);
- template = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+ template_tree
+ = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
/* Otherwise use the {1, LENGTH} template we build above. */
template_addr = build3 (COND_EXPR, p_bounds_type, u,
build_unary_op (ADDR_EXPR, p_bounds_type,
- template),
+ template_tree),
template_addr);
break;
TREE_TYPE (aflags),
aflags, u),
u));
- add_stmt (build3 (COND_EXPR, void_type_node, u,
- build_call_raise (CE_Length_Check_Failed, Empty,
- N_Raise_Constraint_Error),
- NULL_TREE));
/* There is already a template in the descriptor and it is
located at the start of block 3 (12th field). */
t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (t))));
- template = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
- template_addr = build_unary_op (ADDR_EXPR, p_bounds_type, template);
+ template_tree
+ = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
+ template_tree = build3 (COND_EXPR, TREE_TYPE (t), u,
+ build_call_raise (CE_Length_Check_Failed, Empty,
+ N_Raise_Constraint_Error),
+ template_tree);
+ template_addr
+ = build_unary_op (ADDR_EXPR, p_bounds_type, template_tree);
break;
case 10: /* Class NCA */
}
/* Build the fat pointer in the form of a constructor. */
- t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr,
+ t = tree_cons (TYPE_FIELDS (gnu_type), gnu_expr32,
tree_cons (TREE_CHAIN (TYPE_FIELDS (gnu_type)),
template_addr, NULL_TREE));
+
return gnat_build_constructor (gnu_type, t);
}
gcc_unreachable ();
}
+/* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular
+ pointer or fat pointer type. GNU_EXPR_ALT_TYPE is the alternate (32-bit)
+ pointer type of GNU_EXPR. GNAT_SUBPROG is the subprogram to which the
+ VMS descriptor is passed. */
+
+static tree
+convert_vms_descriptor (tree gnu_type, tree gnu_expr, tree gnu_expr_alt_type,
+ Entity_Id gnat_subprog)
+{
+ tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr));
+ tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr);
+ tree mbo = TYPE_FIELDS (desc_type);
+ const char *mbostr = IDENTIFIER_POINTER (DECL_NAME (mbo));
+ tree mbmo = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (mbo)));
+ tree is64bit, gnu_expr32, gnu_expr64;
+
+ /* If the field name is not MBO, it must be 32-bit and no alternate.
+ Otherwise primary must be 64-bit and alternate 32-bit. */
+ if (strcmp (mbostr, "MBO") != 0)
+ return convert_vms_descriptor32 (gnu_type, gnu_expr, gnat_subprog);
+
+ /* Build the test for 64-bit descriptor. */
+ mbo = build3 (COMPONENT_REF, TREE_TYPE (mbo), desc, mbo, NULL_TREE);
+ mbmo = build3 (COMPONENT_REF, TREE_TYPE (mbmo), desc, mbmo, NULL_TREE);
+ is64bit
+ = build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
+ build_binary_op (EQ_EXPR, integer_type_node,
+ convert (integer_type_node, mbo),
+ integer_one_node),
+ build_binary_op (EQ_EXPR, integer_type_node,
+ convert (integer_type_node, mbmo),
+ integer_minus_one_node));
+
+ /* Build the 2 possible end results. */
+ gnu_expr64 = convert_vms_descriptor64 (gnu_type, gnu_expr, gnat_subprog);
+ gnu_expr = fold_convert (gnu_expr_alt_type, gnu_expr);
+ gnu_expr32 = convert_vms_descriptor32 (gnu_type, gnu_expr, gnat_subprog);
+
+ return build3 (COND_EXPR, gnu_type, is64bit, gnu_expr64, gnu_expr32);
+}
+
/* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG
and the GNAT node GNAT_SUBPROG. */
gnu_arg_types = TREE_CHAIN (gnu_arg_types))
{
if (DECL_BY_DESCRIPTOR_P (gnu_stub_param))
- gnu_param = convert_vms_descriptor (TREE_VALUE (gnu_arg_types),
- gnu_stub_param, gnat_subprog);
+ gnu_param
+ = convert_vms_descriptor (TREE_VALUE (gnu_arg_types),
+ gnu_stub_param,
+ DECL_PARM_ALT_TYPE (gnu_stub_param),
+ gnat_subprog);
else
gnu_param = gnu_stub_param;
gnat_poplevel ();
allocate_struct_function (gnu_stub_decl, false);
- end_subprog_body (gnu_body, false);
+ end_subprog_body (gnu_body);
}
\f
/* Build a type to be used to represent an aliased object whose nominal
finish_record_type (type,
chainon (chainon (NULL_TREE, template_field),
array_field),
- 0, false);
+ 0, true);
return type;
}
{
tree template_type;
- gcc_assert (TYPE_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type));
+ gcc_assert (TYPE_IS_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type));
template_type
- = (TYPE_FAT_POINTER_P (thin_fat_ptr_type)
+ = (TYPE_IS_FAT_POINTER_P (thin_fat_ptr_type)
? TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (thin_fat_ptr_type))))
: TREE_TYPE (TYPE_FIELDS (TREE_TYPE (thin_fat_ptr_type))));
return build_unc_object_type (template_type, object_type, name);
DECL_FIELD_BIT_OFFSET (array_field) = bitsize_zero_node;
}
\f
-/* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE. In
- the normal case this is just two adjustments, but we have more to do
- if NEW is an UNCONSTRAINED_ARRAY_TYPE. */
+/* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE.
+ In the normal case this is just two adjustments, but we have more to
+ do if NEW_TYPE is an UNCONSTRAINED_ARRAY_TYPE. */
void
update_pointer_to (tree old_type, tree new_type)
type = TYPE_NEXT_VARIANT (type))
update_pointer_to (type, new_type);
- /* If no pointer or reference, we are done. */
+ /* If no pointers and no references, we are done. */
if (!ptr && !ref)
return;
/* Merge the old type qualifiers in the new type.
Each old variant has qualifiers for specific reasons, and the new
- designated type as well. Each set of qualifiers represents useful
+ designated type as well. Each set of qualifiers represents useful
information grabbed at some point, and merging the two simply unifies
these inputs into the final type description.
Consider for instance a volatile type frozen after an access to constant
- type designating it. After the designated type freeze, we get here with a
- volatile new_type and a dummy old_type with a readonly variant, created
- when the access type was processed. We shall make a volatile and readonly
+ type designating it; after the designated type's freeze, we get here with
+ a volatile NEW_TYPE and a dummy OLD_TYPE with a readonly variant, created
+ when the access type was processed. We will make a volatile and readonly
designated type, because that's what it really is.
- We might also get here for a non-dummy old_type variant with different
- qualifiers than the new_type ones, for instance in some cases of pointers
+ We might also get here for a non-dummy OLD_TYPE variant with different
+ qualifiers than those of NEW_TYPE, for instance in some cases of pointers
to private record type elaboration (see the comments around the call to
- this routine from gnat_to_gnu_entity/E_Access_Type). We have to merge the
- qualifiers in those cases too, to avoid accidentally discarding the
- initial set, and will often end up with old_type == new_type then. */
- new_type = build_qualified_type (new_type,
- TYPE_QUALS (old_type)
- | TYPE_QUALS (new_type));
-
- /* If the new type and the old one are identical, there is nothing to
- update. */
+ this routine in gnat_to_gnu_entity <E_Access_Type>). We have to merge
+ the qualifiers in those cases too, to avoid accidentally discarding the
+ initial set, and will often end up with OLD_TYPE == NEW_TYPE then. */
+ new_type
+ = build_qualified_type (new_type,
+ TYPE_QUALS (old_type) | TYPE_QUALS (new_type));
+
+ /* If old type and new type are identical, there is nothing to do. */
if (old_type == new_type)
return;
TREE_TYPE (ref1) = new_type;
}
- /* Now deal with the unconstrained array case. In this case the "pointer"
+ /* Now deal with the unconstrained array case. In this case the "pointer"
is actually a RECORD_TYPE where both fields are pointers to dummy nodes.
Turn them into pointers to the correct types using update_pointer_to. */
- else if (TREE_CODE (ptr) != RECORD_TYPE || !TYPE_IS_FAT_POINTER_P (ptr))
+ else if (!TYPE_IS_FAT_POINTER_P (ptr))
gcc_unreachable ();
else
TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (new_ptr)))));
/* The references to the template bounds present in the array type
- are made through a PLACEHOLDER_EXPR of type new_ptr. Since we
- are updating ptr to make it a full replacement for new_ptr as
- pointer to new_type, we must rework the PLACEHOLDER_EXPR so as
- to make it of type ptr. */
+ are made through a PLACEHOLDER_EXPR of type NEW_PTR. Since we
+ are updating PTR to make it a full replacement for NEW_PTR as
+ pointer to NEW_TYPE, we must rework the PLACEHOLDER_EXPR so as
+ to make it of type PTR. */
new_ref = build3 (COMPONENT_REF, TREE_TYPE (bounds_field),
build0 (PLACEHOLDER_EXPR, ptr),
bounds_field, NULL_TREE);
- /* Create the new array for the new PLACEHOLDER_EXPR and make
- pointers to the dummy array point to it.
-
- ??? This is now the only use of substitute_in_type,
- which is a very "heavy" routine to do this, so it
- should be replaced at some point. */
+ /* Create the new array for the new PLACEHOLDER_EXPR and make pointers
+ to the dummy array point to it. */
update_pointer_to
(TREE_TYPE (TREE_TYPE (array_field)),
substitute_in_type (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (new_ptr))),
TREE_CHAIN (TYPE_FIELDS (new_ptr)), new_ref));
- /* Make ptr the pointer to new_type. */
+ /* Make PTR the pointer to NEW_TYPE. */
TYPE_POINTER_TO (new_type) = TYPE_REFERENCE_TO (new_type)
= TREE_TYPE (new_type) = ptr;
+ /* And show the original pointer NEW_PTR to the debugger. This is the
+ counterpart of the equivalent processing in gnat_pushdecl when the
+ unconstrained array type is frozen after access types to it. Note
+ that update_pointer_to can be invoked multiple times on the same
+ couple of types because of the type variants. */
+ if (TYPE_NAME (ptr)
+ && TREE_CODE (TYPE_NAME (ptr)) == TYPE_DECL
+ && !DECL_ORIGINAL_TYPE (TYPE_NAME (ptr)))
+ {
+ DECL_ORIGINAL_TYPE (TYPE_NAME (ptr)) = new_ptr;
+ DECL_ARTIFICIAL (TYPE_NAME (ptr)) = 0;
+ }
for (var = TYPE_MAIN_VARIANT (ptr); var; var = TYPE_NEXT_VARIANT (var))
SET_TYPE_UNCONSTRAINED_ARRAY (var, new_type);
}
}
\f
-/* Convert a pointer to a constrained array into a pointer to a fat
- pointer. This involves making or finding a template. */
+/* Convert EXPR, a pointer to a constrained array, into a pointer to an
+ unconstrained one. This involves making or finding a template. */
static tree
convert_to_fat_pointer (tree type, tree expr)
{
tree template_type = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type))));
- tree template, template_addr;
+ tree p_array_type = TREE_TYPE (TYPE_FIELDS (type));
tree etype = TREE_TYPE (expr);
+ tree template_tree;
- /* If EXPR is a constant of zero, we make a fat pointer that has a null
- pointer to the template and array. */
+ /* If EXPR is null, make a fat pointer that contains null pointers to the
+ template and array. */
if (integer_zerop (expr))
return
gnat_build_constructor
(type,
tree_cons (TYPE_FIELDS (type),
- convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
+ convert (p_array_type, expr),
tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
convert (build_pointer_type (template_type),
expr),
NULL_TREE)));
- /* If EXPR is a thin pointer, make the template and data from the record. */
-
- else if (TYPE_THIN_POINTER_P (etype))
+ /* If EXPR is a thin pointer, make template and data from the record.. */
+ else if (TYPE_IS_THIN_POINTER_P (etype))
{
tree fields = TYPE_FIELDS (TREE_TYPE (etype));
else
expr = build1 (INDIRECT_REF, TREE_TYPE (etype), expr);
- template = build_component_ref (expr, NULL_TREE, fields, false);
+ template_tree = build_component_ref (expr, NULL_TREE, fields, false);
expr = build_unary_op (ADDR_EXPR, NULL_TREE,
build_component_ref (expr, NULL_TREE,
TREE_CHAIN (fields), false));
}
- else
- /* Otherwise, build the constructor for the template. */
- template = build_template (template_type, TREE_TYPE (etype), expr);
- template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template);
+ /* Otherwise, build the constructor for the template. */
+ else
+ template_tree = build_template (template_type, TREE_TYPE (etype), expr);
- /* The result is a CONSTRUCTOR for the fat pointer.
+ /* The final result is a constructor for the fat pointer.
- If expr is an argument of a foreign convention subprogram, the type it
- points to is directly the component type. In this case, the expression
+ If EXPR is an argument of a foreign convention subprogram, the type it
+ points to is directly the component type. In this case, the expression
type may not match the corresponding FIELD_DECL type at this point, so we
- call "convert" here to fix that up if necessary. This type consistency is
+ call "convert" here to fix that up if necessary. This type consistency is
required, for instance because it ensures that possible later folding of
- component_refs against this constructor always yields something of the
+ COMPONENT_REFs against this constructor always yields something of the
same type as the initial reference.
- Note that the call to "build_template" above is still fine, because it
- will only refer to the provided template_type in this case. */
- return
- gnat_build_constructor
- (type, tree_cons (TYPE_FIELDS (type),
- convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
- tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
- template_addr, NULL_TREE)));
+ Note that the call to "build_template" above is still fine because it
+ will only refer to the provided TEMPLATE_TYPE in this case. */
+ return
+ gnat_build_constructor
+ (type,
+ tree_cons (TYPE_FIELDS (type),
+ convert (p_array_type, expr),
+ tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
+ build_unary_op (ADDR_EXPR, NULL_TREE,
+ template_tree),
+ NULL_TREE)));
}
\f
/* Convert to a thin pointer type, TYPE. The only thing we know how to convert
static tree
convert_to_thin_pointer (tree type, tree expr)
{
- if (!TYPE_FAT_POINTER_P (TREE_TYPE (expr)))
+ if (!TYPE_IS_FAT_POINTER_P (TREE_TYPE (expr)))
expr
= convert_to_fat_pointer
(TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))), expr);
as an unchecked conversion. Likewise if one is a mere variant of the
other, so we avoid a pointless unpad/repad sequence. */
else if (code == RECORD_TYPE && ecode == RECORD_TYPE
- && TYPE_IS_PADDING_P (type) && TYPE_IS_PADDING_P (etype)
+ && TYPE_PADDING_P (type) && TYPE_PADDING_P (etype)
&& (!TREE_CONSTANT (TYPE_SIZE (type))
|| !TREE_CONSTANT (TYPE_SIZE (etype))
|| gnat_types_compatible_p (type, etype)
== TYPE_NAME (TREE_TYPE (TYPE_FIELDS (etype)))))
;
- /* If the output type has padding, convert to the inner type and
- make a constructor to build the record. */
- else if (code == RECORD_TYPE && TYPE_IS_PADDING_P (type))
+ /* If the output type has padding, convert to the inner type and make a
+ constructor to build the record, unless a variable size is involved. */
+ else if (code == RECORD_TYPE && TYPE_PADDING_P (type))
{
/* If we previously converted from another type and our type is
of variable size, remove the conversion to avoid the need for
- variable-size temporaries. Likewise for a conversion between
+ variable-sized temporaries. Likewise for a conversion between
original and packable version. */
if (TREE_CODE (expr) == VIEW_CONVERT_EXPR
&& (!TREE_CONSTANT (TYPE_SIZE (type))
/* If we are just removing the padding from expr, convert the original
object if we have variable size in order to avoid the need for some
- variable-size temporaries. Likewise if the padding is a mere variant
+ variable-sized temporaries. Likewise if the padding is a variant
of the other, so we avoid a pointless unpad/repad sequence. */
if (TREE_CODE (expr) == COMPONENT_REF
- && TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == RECORD_TYPE
&& TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr, 0)))
&& (!TREE_CONSTANT (TYPE_SIZE (type))
|| gnat_types_compatible_p (type,
== TYPE_NAME (TREE_TYPE (TYPE_FIELDS (type))))))
return convert (type, TREE_OPERAND (expr, 0));
- /* If the result type is a padded type with a self-referentially-sized
- field and the expression type is a record, do this as an
- unchecked conversion. */
- else if (TREE_CODE (etype) == RECORD_TYPE
- && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type))))
- return unchecked_convert (type, expr, false);
+ /* If the inner type is of self-referential size and the expression type
+ is a record, do this as an unchecked conversion. But first pad the
+ expression if possible to have the same size on both sides. */
+ if (TREE_CODE (etype) == RECORD_TYPE
+ && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type))))
+ {
+ if (TREE_CONSTANT (TYPE_SIZE (etype)))
+ expr = convert (maybe_pad_type (etype, TYPE_SIZE (type), 0, Empty,
+ false, false, false, true), expr);
+ return unchecked_convert (type, expr, false);
+ }
- else
- return
- gnat_build_constructor (type,
- tree_cons (TYPE_FIELDS (type),
- convert (TREE_TYPE
- (TYPE_FIELDS (type)),
- expr),
- NULL_TREE));
+ /* If we are converting between array types with variable size, do the
+ final conversion as an unchecked conversion, again to avoid the need
+ for some variable-sized temporaries. If valid, this conversion is
+ very likely purely technical and without real effects. */
+ if (TREE_CODE (etype) == ARRAY_TYPE
+ && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == ARRAY_TYPE
+ && !TREE_CONSTANT (TYPE_SIZE (etype))
+ && !TREE_CONSTANT (TYPE_SIZE (type)))
+ return unchecked_convert (type,
+ convert (TREE_TYPE (TYPE_FIELDS (type)),
+ expr),
+ false);
+
+ return
+ gnat_build_constructor (type,
+ tree_cons (TYPE_FIELDS (type),
+ convert (TREE_TYPE
+ (TYPE_FIELDS (type)),
+ expr),
+ NULL_TREE));
}
/* If the input type has padding, remove it and convert to the output type.
The conditions ordering is arranged to ensure that the output type is not
a padding type here, as it is not clear whether the conversion would
always be correct if this was to happen. */
- else if (ecode == RECORD_TYPE && TYPE_IS_PADDING_P (etype))
+ else if (ecode == RECORD_TYPE && TYPE_PADDING_P (etype))
{
tree unpadded;
}
break;
+ case VECTOR_CST:
+ /* If we are converting a VECTOR_CST to a mere variant type, just make
+ a new one in the proper type. */
+ if (code == ecode && gnat_types_compatible_p (type, etype))
+ {
+ expr = copy_node (expr);
+ TREE_TYPE (expr) = type;
+ return expr;
+ }
+
case CONSTRUCTOR:
/* If we are converting a CONSTRUCTOR to a mere variant type, just make
a new one in the proper type. */
unsigned HOST_WIDE_INT idx;
tree index, value;
+ /* Whether we need to clear TREE_CONSTANT et al. on the output
+ constructor when we convert in place. */
+ bool clear_constant = false;
+
FOR_EACH_CONSTRUCTOR_ELT(e, idx, index, value)
{
constructor_elt *elt = VEC_quick_push (constructor_elt, v, NULL);
break;
elt->index = field;
elt->value = convert (TREE_TYPE (field), value);
+
+ /* If packing has made this field a bitfield and the input
+ value couldn't be emitted statically any more, we need to
+ clear TREE_CONSTANT on our output. */
+ if (!clear_constant && TREE_CONSTANT (expr)
+ && !CONSTRUCTOR_BITFIELD_P (efield)
+ && CONSTRUCTOR_BITFIELD_P (field)
+ && !initializer_constant_valid_for_bitfield_p (value))
+ clear_constant = true;
+
efield = TREE_CHAIN (efield);
field = TREE_CHAIN (field);
}
+ /* If we have been able to match and convert all the input fields
+ to their output type, convert in place now. We'll fallback to a
+ view conversion downstream otherwise. */
if (idx == len)
{
expr = copy_node (expr);
TREE_TYPE (expr) = type;
CONSTRUCTOR_ELTS (expr) = v;
+ if (clear_constant)
+ TREE_CONSTANT (expr) = TREE_STATIC (expr) = false;
return expr;
}
}
+
+ /* Likewise for a conversion between array type and vector type with a
+ compatible representative array. */
+ else if (code == VECTOR_TYPE
+ && ecode == ARRAY_TYPE
+ && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type),
+ etype))
+ {
+ VEC(constructor_elt,gc) *e = CONSTRUCTOR_ELTS (expr);
+ unsigned HOST_WIDE_INT len = VEC_length (constructor_elt, e);
+ VEC(constructor_elt,gc) *v;
+ unsigned HOST_WIDE_INT ix;
+ tree value;
+
+ /* Build a VECTOR_CST from a *constant* array constructor. */
+ if (TREE_CONSTANT (expr))
+ {
+ bool constant_p = true;
+
+ /* Iterate through elements and check if all constructor
+ elements are *_CSTs. */
+ FOR_EACH_CONSTRUCTOR_VALUE (e, ix, value)
+ if (!CONSTANT_CLASS_P (value))
+ {
+ constant_p = false;
+ break;
+ }
+
+ if (constant_p)
+ return build_vector_from_ctor (type,
+ CONSTRUCTOR_ELTS (expr));
+ }
+
+ /* Otherwise, build a regular vector constructor. */
+ v = VEC_alloc (constructor_elt, gc, len);
+ FOR_EACH_CONSTRUCTOR_VALUE (e, ix, value)
+ {
+ constructor_elt *elt = VEC_quick_push (constructor_elt, v, NULL);
+ elt->index = NULL_TREE;
+ elt->value = value;
+ }
+ expr = copy_node (expr);
+ TREE_TYPE (expr) = type;
+ CONSTRUCTOR_ELTS (expr) = v;
+ return expr;
+ }
break;
case UNCONSTRAINED_ARRAY_REF:
if (type == TREE_TYPE (op0))
return op0;
- /* Otherwise, if we're converting between two aggregate types, we
- might be allowed to substitute the VIEW_CONVERT_EXPR target type
- in place or to just convert the inner expression. */
- if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype))
+ /* Otherwise, if we're converting between two aggregate or vector
+ types, we might be allowed to substitute the VIEW_CONVERT_EXPR
+ target type in place or to just convert the inner expression. */
+ if ((AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype))
+ || (VECTOR_TYPE_P (type) && VECTOR_TYPE_P (etype)))
{
/* If we are converting between mere variants, we can just
substitute the VIEW_CONVERT_EXPR in place. */
/* Otherwise, we may just bypass the input view conversion unless
one of the types is a fat pointer, which is handled by
specialized code below which relies on exact type matching. */
- else if (!TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype))
+ else if (!TYPE_IS_FAT_POINTER_P (type)
+ && !TYPE_IS_FAT_POINTER_P (etype))
return convert (type, op0);
}
}
|| TREE_CODE (type) == UNION_TYPE)
&& (TREE_CODE (etype) == RECORD_TYPE
|| TREE_CODE (etype) == UNION_TYPE)
- && !TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype))
+ && !TYPE_IS_FAT_POINTER_P (type) && !TYPE_IS_FAT_POINTER_P (etype))
return build_unary_op (INDIRECT_REF, NULL_TREE,
convert (build_pointer_type (type),
TREE_OPERAND (expr, 0)));
}
/* Check for converting to a pointer to an unconstrained array. */
- if (TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype))
+ if (TYPE_IS_FAT_POINTER_P (type) && !TYPE_IS_FAT_POINTER_P (etype))
return convert_to_fat_pointer (type, expr);
- /* If we are converting between two aggregate types that are mere
- variants, just make a VIEW_CONVERT_EXPR. */
- else if (code == ecode
- && AGGREGATE_TYPE_P (type)
- && gnat_types_compatible_p (type, etype))
+ /* If we are converting between two aggregate or vector types that are mere
+ variants, just make a VIEW_CONVERT_EXPR. Likewise when we are converting
+ to a vector type from its representative array type. */
+ else if ((code == ecode
+ && (AGGREGATE_TYPE_P (type) || VECTOR_TYPE_P (type))
+ && gnat_types_compatible_p (type, etype))
+ || (code == VECTOR_TYPE
+ && ecode == ARRAY_TYPE
+ && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type),
+ etype)))
return build1 (VIEW_CONVERT_EXPR, type, expr);
/* In all other cases of related types, make a NOP_EXPR. */
/* If converting between two pointers to records denoting
both a template and type, adjust if needed to account
for any differing offsets, since one might be negative. */
- if (TYPE_THIN_POINTER_P (etype) && TYPE_THIN_POINTER_P (type))
+ if (TYPE_IS_THIN_POINTER_P (etype) && TYPE_IS_THIN_POINTER_P (type))
{
tree bit_diff
= size_diffop (bit_position (TYPE_FIELDS (TREE_TYPE (etype))),
}
/* If converting to a thin pointer, handle specially. */
- if (TYPE_THIN_POINTER_P (type)
+ if (TYPE_IS_THIN_POINTER_P (type)
&& TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)))
return convert_to_thin_pointer (type, expr);
/* If converting fat pointer to normal pointer, get the pointer to the
array and then convert it. */
- else if (TYPE_FAT_POINTER_P (etype))
+ else if (TYPE_IS_FAT_POINTER_P (etype))
expr = build_component_ref (expr, get_identifier ("P_ARRAY"),
NULL_TREE, false);
return unchecked_convert (type, expr, false);
case UNCONSTRAINED_ARRAY_TYPE:
+ /* If the input is a VECTOR_TYPE, convert to the representative
+ array type first. */
+ if (ecode == VECTOR_TYPE)
+ {
+ expr = convert (TYPE_REPRESENTATIVE_ARRAY (etype), expr);
+ etype = TREE_TYPE (expr);
+ ecode = TREE_CODE (etype);
+ }
+
/* If EXPR is a constrained array, take its address, convert it to a
fat pointer, and then dereference it. Likewise if EXPR is a
record containing both a template and a constrained array.
break;
case COMPONENT_REF:
- if (TREE_CODE (TREE_TYPE (TREE_OPERAND (exp, 0))) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
+ if (TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
return remove_conversions (TREE_OPERAND (exp, 0), true_address);
break;
maybe_unconstrained_array (tree exp)
{
enum tree_code code = TREE_CODE (exp);
- tree new;
+ tree new_exp;
switch (TREE_CODE (TREE_TYPE (exp)))
{
case UNCONSTRAINED_ARRAY_TYPE:
if (code == UNCONSTRAINED_ARRAY_REF)
{
- new
+ new_exp
= build_unary_op (INDIRECT_REF, NULL_TREE,
build_component_ref (TREE_OPERAND (exp, 0),
get_identifier ("P_ARRAY"),
NULL_TREE, false));
- TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp);
- return new;
+ TREE_READONLY (new_exp) = TREE_STATIC (new_exp)
+ = TREE_READONLY (exp);
+ return new_exp;
}
else if (code == NULL_EXPR)
case RECORD_TYPE:
/* If this is a padded type, convert to the unpadded type and see if
it contains a template. */
- if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
+ if (TYPE_PADDING_P (TREE_TYPE (exp)))
{
- new = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
- if (TREE_CODE (TREE_TYPE (new)) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new)))
+ new_exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
+ if (TREE_CODE (TREE_TYPE (new_exp)) == RECORD_TYPE
+ && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new_exp)))
return
- build_component_ref (new, NULL_TREE,
- TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new))),
+ build_component_ref (new_exp, NULL_TREE,
+ TREE_CHAIN
+ (TYPE_FIELDS (TREE_TYPE (new_exp))),
0);
}
else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp)))
return exp;
}
+
+/* If EXP's type is a VECTOR_TYPE, return EXP converted to the associated
+ TYPE_REPRESENTATIVE_ARRAY. */
+
+tree
+maybe_vector_array (tree exp)
+{
+ tree etype = TREE_TYPE (exp);
+
+ if (VECTOR_TYPE_P (etype))
+ exp = convert (TYPE_REPRESENTATIVE_ARRAY (etype), exp);
+
+ return exp;
+}
\f
+/* Return true if EXPR is an expression that can be folded as an operand
+ of a VIEW_CONVERT_EXPR. See ada-tree.h for a complete rationale. */
+
+static bool
+can_fold_for_view_convert_p (tree expr)
+{
+ tree t1, t2;
+
+ /* The folder will fold NOP_EXPRs between integral types with the same
+ precision (in the middle-end's sense). We cannot allow it if the
+ types don't have the same precision in the Ada sense as well. */
+ if (TREE_CODE (expr) != NOP_EXPR)
+ return true;
+
+ t1 = TREE_TYPE (expr);
+ t2 = TREE_TYPE (TREE_OPERAND (expr, 0));
+
+ /* Defer to the folder for non-integral conversions. */
+ if (!(INTEGRAL_TYPE_P (t1) && INTEGRAL_TYPE_P (t2)))
+ return true;
+
+ /* Only fold conversions that preserve both precisions. */
+ if (TYPE_PRECISION (t1) == TYPE_PRECISION (t2)
+ && operand_equal_p (rm_size (t1), rm_size (t2), 0))
+ return true;
+
+ return false;
+}
+
/* Return an expression that does an unchecked conversion of EXPR to TYPE.
- If NOTRUNC_P is true, truncation operations should be suppressed. */
+ If NOTRUNC_P is true, truncation operations should be suppressed.
+
+ Special care is required with (source or target) integral types whose
+ precision is not equal to their size, to make sure we fetch or assign
+ the value bits whose location might depend on the endianness, e.g.
+
+ Rmsize : constant := 8;
+ subtype Int is Integer range 0 .. 2 ** Rmsize - 1;
+
+ type Bit_Array is array (1 .. Rmsize) of Boolean;
+ pragma Pack (Bit_Array);
+
+ function To_Bit_Array is new Unchecked_Conversion (Int, Bit_Array);
+
+ Value : Int := 2#1000_0001#;
+ Vbits : Bit_Array := To_Bit_Array (Value);
+
+ we expect the 8 bits at Vbits'Address to always contain Value, while
+ their original location depends on the endianness, at Value'Address
+ on a little-endian architecture but not on a big-endian one. */
tree
unchecked_convert (tree type, tree expr, bool notrunc_p)
if ((((INTEGRAL_TYPE_P (type)
&& !(TREE_CODE (type) == INTEGER_TYPE
&& TYPE_VAX_FLOATING_POINT_P (type)))
- || (POINTER_TYPE_P (type) && ! TYPE_THIN_POINTER_P (type))
+ || (POINTER_TYPE_P (type) && ! TYPE_IS_THIN_POINTER_P (type))
|| (TREE_CODE (type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (type)))
&& ((INTEGRAL_TYPE_P (etype)
&& !(TREE_CODE (etype) == INTEGER_TYPE
&& TYPE_VAX_FLOATING_POINT_P (etype)))
- || (POINTER_TYPE_P (etype) && !TYPE_THIN_POINTER_P (etype))
+ || (POINTER_TYPE_P (etype) && !TYPE_IS_THIN_POINTER_P (etype))
|| (TREE_CODE (etype) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (etype))))
|| TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
{
- tree rtype = type;
- bool final_unchecked = false;
-
if (TREE_CODE (etype) == INTEGER_TYPE
&& TYPE_BIASED_REPRESENTATION_P (etype))
{
tree ntype = copy_type (etype);
-
TYPE_BIASED_REPRESENTATION_P (ntype) = 0;
TYPE_MAIN_VARIANT (ntype) = ntype;
expr = build1 (NOP_EXPR, ntype, expr);
if (TREE_CODE (type) == INTEGER_TYPE
&& TYPE_BIASED_REPRESENTATION_P (type))
{
- rtype = copy_type (type);
+ tree rtype = copy_type (type);
TYPE_BIASED_REPRESENTATION_P (rtype) = 0;
TYPE_MAIN_VARIANT (rtype) = rtype;
+ expr = convert (rtype, expr);
+ expr = build1 (NOP_EXPR, type, expr);
}
-
- /* We have another special case: if we are unchecked converting subtype
- into a base type, we need to ensure that VRP doesn't propagate range
- information since this conversion may be done precisely to validate
- that the object is within the range it is supposed to have. */
- else if (TREE_CODE (expr) != INTEGER_CST
- && TREE_CODE (type) == INTEGER_TYPE && !TREE_TYPE (type)
- && ((TREE_CODE (etype) == INTEGER_TYPE && TREE_TYPE (etype))
- || TREE_CODE (etype) == ENUMERAL_TYPE
- || TREE_CODE (etype) == BOOLEAN_TYPE))
- {
- /* The optimization barrier is a VIEW_CONVERT_EXPR node; moreover,
- in order not to be deemed an useless type conversion, it must
- be from subtype to base type.
-
- ??? This may raise addressability and/or aliasing issues because
- VIEW_CONVERT_EXPR gets gimplified as an lvalue, thus causing the
- address of its operand to be taken if it is deemed addressable
- and not already in GIMPLE form. */
- rtype = gnat_type_for_mode (TYPE_MODE (type), TYPE_UNSIGNED (type));
- rtype = copy_type (rtype);
- TYPE_MAIN_VARIANT (rtype) = rtype;
- TREE_TYPE (rtype) = type;
- final_unchecked = true;
- }
-
- expr = convert (rtype, expr);
- if (type != rtype)
- expr = fold_build1 (final_unchecked ? VIEW_CONVERT_EXPR : NOP_EXPR,
- type, expr);
+ else
+ expr = convert (type, expr);
}
- /* If we are converting TO an integral type whose precision is not the
- same as its size, first unchecked convert to a record that contains
- an object of the output type. Then extract the field. */
+ /* If we are converting to an integral type whose precision is not equal
+ to its size, first unchecked convert to a record that contains an
+ object of the output type. Then extract the field. */
else if (INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type)
&& 0 != compare_tree_int (TYPE_RM_SIZE (type),
GET_MODE_BITSIZE (TYPE_MODE (type))))
expr = build_component_ref (expr, NULL_TREE, field, 0);
}
- /* Similarly for integral input type whose precision is not equal to its
- size. */
+ /* Similarly if we are converting from an integral type whose precision
+ is not equal to its size. */
else if (INTEGRAL_TYPE_P (etype) && TYPE_RM_SIZE (etype)
&& 0 != compare_tree_int (TYPE_RM_SIZE (etype),
GET_MODE_BITSIZE (TYPE_MODE (etype))))
expr = unchecked_convert (type, expr, notrunc_p);
}
- /* We have a special case when we are converting between two
- unconstrained array types. In that case, take the address,
- convert the fat pointer types, and dereference. */
+ /* We have a special case when we are converting between two unconstrained
+ array types. In that case, take the address, convert the fat pointer
+ types, and dereference. */
else if (TREE_CODE (etype) == UNCONSTRAINED_ARRAY_TYPE
&& TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
expr = build_unary_op (INDIRECT_REF, NULL_TREE,
build1 (VIEW_CONVERT_EXPR, TREE_TYPE (type),
build_unary_op (ADDR_EXPR, NULL_TREE,
expr)));
+
+ /* Another special case is when we are converting to a vector type from its
+ representative array type; this a regular conversion. */
+ else if (TREE_CODE (type) == VECTOR_TYPE
+ && TREE_CODE (etype) == ARRAY_TYPE
+ && gnat_types_compatible_p (TYPE_REPRESENTATIVE_ARRAY (type),
+ etype))
+ expr = convert (type, expr);
+
else
{
expr = maybe_unconstrained_array (expr);
etype = TREE_TYPE (expr);
- expr = fold_build1 (VIEW_CONVERT_EXPR, type, expr);
+ if (can_fold_for_view_convert_p (expr))
+ expr = fold_build1 (VIEW_CONVERT_EXPR, type, expr);
+ else
+ expr = build1 (VIEW_CONVERT_EXPR, type, expr);
}
- /* If the result is an integral type whose size is not equal to
- the size of the underlying machine type, sign- or zero-extend
- the result. We need not do this in the case where the input is
- an integral type of the same precision and signedness or if the output
+ /* If the result is an integral type whose precision is not equal to its
+ size, sign- or zero-extend the result. We need not do this if the input
+ is an integral type of the same precision and signedness or if the output
is a biased type or if both the input and output are unsigned. */
if (!notrunc_p
&& INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type)
return expr;
}
\f
-/* Return the appropriate GCC tree code for the specified GNAT type,
+/* Return the appropriate GCC tree code for the specified GNAT_TYPE,
the latter being a record type as predicated by Is_Record_Type. */
enum tree_code
return UNION_TYPE;
}
+/* Return true if GNAT_TYPE is a "double" floating-point type, i.e. whose
+ size is equal to 64 bits, or an array of such a type. Set ALIGN_CLAUSE
+ according to the presence of an alignment clause on the type or, if it
+ is an array, on the component type. */
+
+bool
+is_double_float_or_array (Entity_Id gnat_type, bool *align_clause)
+{
+ gnat_type = Underlying_Type (gnat_type);
+
+ *align_clause = Present (Alignment_Clause (gnat_type));
+
+ if (Is_Array_Type (gnat_type))
+ {
+ gnat_type = Underlying_Type (Component_Type (gnat_type));
+ if (Present (Alignment_Clause (gnat_type)))
+ *align_clause = true;
+ }
+
+ if (!Is_Floating_Point_Type (gnat_type))
+ return false;
+
+ if (UI_To_Int (Esize (gnat_type)) != 64)
+ return false;
+
+ return true;
+}
+
+/* Return true if GNAT_TYPE is a "double" or larger scalar type, i.e. whose
+ size is greater or equal to 64 bits, or an array of such a type. Set
+ ALIGN_CLAUSE according to the presence of an alignment clause on the
+ type or, if it is an array, on the component type. */
+
+bool
+is_double_scalar_or_array (Entity_Id gnat_type, bool *align_clause)
+{
+ gnat_type = Underlying_Type (gnat_type);
+
+ *align_clause = Present (Alignment_Clause (gnat_type));
+
+ if (Is_Array_Type (gnat_type))
+ {
+ gnat_type = Underlying_Type (Component_Type (gnat_type));
+ if (Present (Alignment_Clause (gnat_type)))
+ *align_clause = true;
+ }
+
+ if (!Is_Scalar_Type (gnat_type))
+ return false;
+
+ if (UI_To_Int (Esize (gnat_type)) < 64)
+ return false;
+
+ return true;
+}
+
/* Return true if GNU_TYPE is suitable as the type of a non-aliased
component of an aggregate type. */
{
/* Proceed to optimize and emit assembly.
FIXME: shouldn't be the front end's responsibility to call this. */
- cgraph_optimize ();
+ cgraph_finalize_compilation_unit ();
/* Emit debug info for all global declarations. */
emit_debug_global_declarations (VEC_address (tree, global_decls),
va_start (list, n);
for (i = 0; i < n; ++i)
{
- builtin_type a = va_arg (list, builtin_type);
+ builtin_type a = (builtin_type) va_arg (list, int);
t = builtin_types[a];
if (t == error_mark_node)
goto egress;
/* ??? TODO: Support types. */
else
{
- warning (OPT_Wattributes, "%qE attribute ignored", name);
+ warning (OPT_Wattributes, "%qs attribute ignored",
+ IDENTIFIER_POINTER (name));
*no_add_attrs = true;
}
if (!params)
{
warning (OPT_Wattributes,
- "%qE attribute requires prototypes with named arguments", name);
+ "%qs attribute requires prototypes with named arguments",
+ IDENTIFIER_POINTER (name));
*no_add_attrs = true;
}
else
if (VOID_TYPE_P (TREE_VALUE (params)))
{
warning (OPT_Wattributes,
- "%qE attribute only applies to variadic functions", name);
+ "%qs attribute only applies to variadic functions",
+ IDENTIFIER_POINTER (name));
*no_add_attrs = true;
}
}
TYPE_READONLY (TREE_TYPE (type)), 1));
else
{
- warning (OPT_Wattributes, "%qE attribute ignored", name);
+ warning (OPT_Wattributes, "%qs attribute ignored",
+ IDENTIFIER_POINTER (name));
*no_add_attrs = true;
}
DECL_IS_MALLOC (*node) = 1;
else
{
- warning (OPT_Wattributes, "%qE attribute ignored", name);
+ warning (OPT_Wattributes, "%qs attribute ignored",
+ IDENTIFIER_POINTER (name));
*no_add_attrs = true;
}
bool * ARG_UNUSED (no_add_attrs))
{
tree params;
-
+
/* Ensure we have a function type. */
gcc_assert (TREE_CODE (*node) == FUNCTION_TYPE);
-
+
params = TYPE_ARG_TYPES (*node);
while (params && ! VOID_TYPE_P (TREE_VALUE (params)))
params = TREE_CHAIN (params);
return NULL_TREE;
}
+/* Handle a "vector_size" attribute; arguments as in
+ struct attribute_spec.handler. */
+
+static tree
+handle_vector_size_attribute (tree *node, tree name, tree args,
+ int ARG_UNUSED (flags),
+ bool *no_add_attrs)
+{
+ unsigned HOST_WIDE_INT vecsize, nunits;
+ enum machine_mode orig_mode;
+ tree type = *node, new_type, size;
+
+ *no_add_attrs = true;
+
+ size = TREE_VALUE (args);
+
+ if (!host_integerp (size, 1))
+ {
+ warning (OPT_Wattributes, "%qs attribute ignored",
+ IDENTIFIER_POINTER (name));
+ return NULL_TREE;
+ }
+
+ /* Get the vector size (in bytes). */
+ vecsize = tree_low_cst (size, 1);
+
+ /* We need to provide for vector pointers, vector arrays, and
+ functions returning vectors. For example:
+
+ __attribute__((vector_size(16))) short *foo;
+
+ In this case, the mode is SI, but the type being modified is
+ HI, so we need to look further. */
+
+ while (POINTER_TYPE_P (type)
+ || TREE_CODE (type) == FUNCTION_TYPE
+ || TREE_CODE (type) == METHOD_TYPE
+ || TREE_CODE (type) == ARRAY_TYPE
+ || TREE_CODE (type) == OFFSET_TYPE)
+ type = TREE_TYPE (type);
+
+ /* Get the mode of the type being modified. */
+ orig_mode = TYPE_MODE (type);
+
+ if ((!INTEGRAL_TYPE_P (type)
+ && !SCALAR_FLOAT_TYPE_P (type)
+ && !FIXED_POINT_TYPE_P (type))
+ || (!SCALAR_FLOAT_MODE_P (orig_mode)
+ && GET_MODE_CLASS (orig_mode) != MODE_INT
+ && !ALL_SCALAR_FIXED_POINT_MODE_P (orig_mode))
+ || !host_integerp (TYPE_SIZE_UNIT (type), 1)
+ || TREE_CODE (type) == BOOLEAN_TYPE)
+ {
+ error ("invalid vector type for attribute %qs",
+ IDENTIFIER_POINTER (name));
+ return NULL_TREE;
+ }
+
+ if (vecsize % tree_low_cst (TYPE_SIZE_UNIT (type), 1))
+ {
+ error ("vector size not an integral multiple of component size");
+ return NULL;
+ }
+
+ if (vecsize == 0)
+ {
+ error ("zero vector size");
+ return NULL;
+ }
+
+ /* Calculate how many units fit in the vector. */
+ nunits = vecsize / tree_low_cst (TYPE_SIZE_UNIT (type), 1);
+ if (nunits & (nunits - 1))
+ {
+ error ("number of components of the vector not a power of two");
+ return NULL_TREE;
+ }
+
+ new_type = build_vector_type (type, nunits);
+
+ /* Build back pointers if needed. */
+ *node = lang_hooks.types.reconstruct_complex_type (*node, new_type);
+
+ return NULL_TREE;
+}
+
+/* Handle a "vector_type" attribute; arguments as in
+ struct attribute_spec.handler. */
+
+static tree
+handle_vector_type_attribute (tree *node, tree name, tree ARG_UNUSED (args),
+ int ARG_UNUSED (flags),
+ bool *no_add_attrs)
+{
+ /* Vector representative type and size. */
+ tree rep_type = *node;
+ tree rep_size = TYPE_SIZE_UNIT (rep_type);
+ tree rep_name;
+
+ /* Vector size in bytes and number of units. */
+ unsigned HOST_WIDE_INT vec_bytes, vec_units;
+
+ /* Vector element type and mode. */
+ tree elem_type;
+ enum machine_mode elem_mode;
+
+ *no_add_attrs = true;
+
+ /* Get the representative array type, possibly nested within a
+ padding record e.g. for alignment purposes. */
+
+ if (TYPE_IS_PADDING_P (rep_type))
+ rep_type = TREE_TYPE (TYPE_FIELDS (rep_type));
+
+ if (TREE_CODE (rep_type) != ARRAY_TYPE)
+ {
+ error ("attribute %qs applies to array types only",
+ IDENTIFIER_POINTER (name));
+ return NULL_TREE;
+ }
+
+ /* Silently punt on variable sizes. We can't make vector types for them,
+ need to ignore them on front-end generated subtypes of unconstrained
+ bases, and this attribute is for binding implementors, not end-users, so
+ we should never get there from legitimate explicit uses. */
+
+ if (!host_integerp (rep_size, 1))
+ return NULL_TREE;
+
+ /* Get the element type/mode and check this is something we know
+ how to make vectors of. */
+
+ elem_type = TREE_TYPE (rep_type);
+ elem_mode = TYPE_MODE (elem_type);
+
+ if ((!INTEGRAL_TYPE_P (elem_type)
+ && !SCALAR_FLOAT_TYPE_P (elem_type)
+ && !FIXED_POINT_TYPE_P (elem_type))
+ || (!SCALAR_FLOAT_MODE_P (elem_mode)
+ && GET_MODE_CLASS (elem_mode) != MODE_INT
+ && !ALL_SCALAR_FIXED_POINT_MODE_P (elem_mode))
+ || !host_integerp (TYPE_SIZE_UNIT (elem_type), 1))
+ {
+ error ("invalid element type for attribute %qs",
+ IDENTIFIER_POINTER (name));
+ return NULL_TREE;
+ }
+
+ /* Sanity check the vector size and element type consistency. */
+
+ vec_bytes = tree_low_cst (rep_size, 1);
+
+ if (vec_bytes % tree_low_cst (TYPE_SIZE_UNIT (elem_type), 1))
+ {
+ error ("vector size not an integral multiple of component size");
+ return NULL;
+ }
+
+ if (vec_bytes == 0)
+ {
+ error ("zero vector size");
+ return NULL;
+ }
+
+ vec_units = vec_bytes / tree_low_cst (TYPE_SIZE_UNIT (elem_type), 1);
+ if (vec_units & (vec_units - 1))
+ {
+ error ("number of components of the vector not a power of two");
+ return NULL_TREE;
+ }
+
+ /* Build the vector type and replace. */
+
+ *node = build_vector_type (elem_type, vec_units);
+ rep_name = TYPE_NAME (rep_type);
+ if (TREE_CODE (rep_name) == TYPE_DECL)
+ rep_name = DECL_NAME (rep_name);
+ TYPE_NAME (*node) = rep_name;
+ TYPE_REPRESENTATIVE_ARRAY (*node) = rep_type;
+
+ return NULL_TREE;
+}
+
/* ----------------------------------------------------------------------- *
* BUILTIN FUNCTIONS *
* ----------------------------------------------------------------------- */
OSDN Git Service
