* *
* 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- *
#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"
/* 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 *);
/* 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);
}
/* 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))
{
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 (boolean_type_node) = bitsize_int (1);
+
build_common_tree_nodes_2 (0);
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;
- 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);
+ tree type_decl = build_decl (TYPE_DECL, get_identifier (name), 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;
+ gnat_pushdecl (type_decl, Empty);
- 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);
-
- /* 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);
-
- 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);
- }
-
- /* 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,
bool had_align = TYPE_ALIGN (record_type) != 0;
tree field;
- 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;
+ /* 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_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;
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);
+ /* If the type is discriminated, it can be used to access all its
+ constrained subtypes, so force structural equality checks. */
+ if (CONTAINS_PLACEHOLDER_P (size))
+ SET_TYPE_STRUCTURAL_EQUALITY (record_type);
+
if (rep_level < 2)
{
/* If this is a padding record, we never want to make the size smaller
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,
return new;
}
\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;
}
\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 (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 (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 == 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
TREE_STATIC (var_decl)
= !extern_flag && (public_flag || static_flag || global_bindings_p ());
+ /* 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;
+
if (asm_name && VAR_OR_FUNCTION_DECL_P (var_decl))
SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
}
}
-/* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its
+/* Return 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
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)
+ /* 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)));
+ tree subtype = make_node (INTEGER_TYPE);
+ TREE_TYPE (subtype) = integer_type_node;
+ TYPE_BIASED_REPRESENTATION_P (subtype) = 1;
+
+ TYPE_UNSIGNED (subtype) = 1;
+ TYPE_PRECISION (subtype) = TYPE_PRECISION (integer_type_node);
+ TYPE_MIN_VALUE (subtype) = TYPE_MIN_VALUE (param_type);
+ TYPE_MAX_VALUE (subtype) = TYPE_MAX_VALUE (param_type);
+ layout_type (subtype);
- TYPE_BIASED_REPRESENTATION_P (param_type) = 1;
+ 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 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)
+ /* 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_ARTIFICIAL (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);
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 ();
for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
gnat_gimplify_function (cgn->decl);
}
-\f
tree
gnat_builtin_function (tree decl)
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
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;
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;
{
case INTEGER_TYPE:
case ENUMERAL_TYPE:
+ case BOOLEAN_TYPE:
if (TYPE_VAX_FLOATING_POINT_P (type))
switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
{
switch (mech)
{
case By_Descriptor_A:
+ case By_Short_Descriptor_A:
class = 4;
break;
case By_Descriptor_NCA:
+ case By_Short_Descriptor_NCA:
class = 10;
break;
case By_Descriptor_SB:
+ case By_Short_Descriptor_SB:
class = 15;
break;
case By_Descriptor:
+ case By_Short_Descriptor:
case By_Descriptor_S:
+ case By_Short_Descriptor_S:
default:
class = 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",
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);
}
+ TYPE_NAME (record_type) = create_concat_name (gnat_entity, "DESC");
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);
-
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;
{
case INTEGER_TYPE:
case ENUMERAL_TYPE:
+ case BOOLEAN_TYPE:
if (TYPE_VAX_FLOATING_POINT_P (type))
switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
{
post_error ("unsupported descriptor type for &", gnat_entity);
}
+ TYPE_NAME (record64_type) = create_concat_name (gnat_entity, "DESC64");
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);
-
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_descriptor (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog)
+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 class = 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 (class)));
+
+ /* 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_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;
+ /* See the head comment of build_vms_descriptor. */
+ int iclass = TREE_INT_CST_LOW (DECL_INITIAL (class));
+ tree lfield, ufield;
+
+ /* Convert POINTER to the type of the P_ARRAY field. */
+ gnu_expr64 = convert (p_array_type, gnu_expr64);
+
+ switch (iclass)
+ {
+ case 1: /* Class S */
+ case 15: /* Class SB */
+ /* Build {1, LENGTH} template; LENGTH64 is the 5th field. */
+ t = TREE_CHAIN (TREE_CHAIN (class));
+ 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 = gnat_build_constructor (template_type, t);
+ template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template);
+
+ /* For class S, we are done. */
+ if (iclass == 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));
+ 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 = 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),
+ 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 = gnat_build_constructor (template_type, t);
+ template = build3 (COND_EXPR, p_bounds_type, u,
+ build_call_raise (CE_Length_Check_Failed, Empty,
+ N_Raise_Constraint_Error),
+ template);
+ template_addr = build_unary_op (ADDR_EXPR, p_bounds_type, template);
+ 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_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);
tree pointer = TREE_CHAIN (class);
/* 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))
{
int iclass = TREE_INT_CST_LOW (DECL_INITIAL (class));
/* 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)
{
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 = build3 (COND_EXPR, p_bounds_type, u,
+ build_call_raise (CE_Length_Check_Failed, Empty,
+ N_Raise_Constraint_Error),
+ template);
template_addr = build_unary_op (ADDR_EXPR, p_bounds_type, template);
break;
}
/* 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;
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_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;
}
}
\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;
- /* 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. */
-
+ /* If EXPR is a thin pointer, make template and data from the record.. */
else if (TYPE_THIN_POINTER_P (etype))
{
tree fields = TYPE_FIELDS (TREE_TYPE (etype));
build_component_ref (expr, NULL_TREE,
TREE_CHAIN (fields), false));
}
+
+ /* Otherwise, build the constructor for the template. */
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);
-
- /* 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),
+ NULL_TREE)));
}
\f
/* Convert to a thin pointer type, TYPE. The only thing we know how to convert
case VOID_TYPE:
return fold_build1 (CONVERT_EXPR, type, expr);
- case BOOLEAN_TYPE:
- return fold_convert (type, gnat_truthvalue_conversion (expr));
-
case INTEGER_TYPE:
if (TYPE_HAS_ACTUAL_BOUNDS_P (type)
&& (ecode == ARRAY_TYPE || ecode == UNCONSTRAINED_ARRAY_TYPE
/* ... fall through ... */
case ENUMERAL_TYPE:
+ case BOOLEAN_TYPE:
/* If we are converting an additive expression to an integer type
with lower precision, be wary of the optimization that can be
applied by convert_to_integer. There are 2 problematic cases:
return exp;
}
\f
+/* Return true if EXPR is an expression that can be folded as an operand
+ of a VIEW_CONVERT_EXPR. See the head comment of unchecked_convert for
+ the 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.
+
+ ??? There is a problematic discrepancy between what is called precision
+ here (and more generally throughout gigi) for integral types and what is
+ called precision in the middle-end. In the former case it's the RM size
+ as given by TYPE_RM_SIZE (or rm_size) whereas it's TYPE_PRECISION in the
+ latter case, the hitch being that they are not equal when they matter,
+ that is when the number of value bits is not equal to the type's size:
+ TYPE_RM_SIZE does give the number of value bits but TYPE_PRECISION is set
+ to the size. The sole exception are BOOLEAN_TYPEs for which both are 1.
+
+ The consequence is that gigi must duplicate code bridging the gap between
+ the type's size and its precision that exists for TYPE_PRECISION in the
+ middle-end, because the latter knows nothing about TYPE_RM_SIZE, and be
+ wary of transformations applied in the middle-end based on TYPE_PRECISION
+ because this value doesn't reflect the actual precision for Ada. */
tree
unchecked_convert (tree type, tree expr, bool notrunc_p)
&& 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. */
+ /* We have another special case: if we are unchecked converting either
+ a subtype or a type with limited range into a base type, we need to
+ ensure that VRP doesn't propagate range information because 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))
in order not to be deemed an useless type conversion, it must
be from subtype to base type.
+ Therefore we first do the bulk of the conversion to a subtype of
+ the final type. And this conversion must itself not be deemed
+ useless if the source type is not a subtype because, otherwise,
+ the final VIEW_CONVERT_EXPR will be deemed so as well. That's
+ why we toggle the unsigned flag in this conversion, which is
+ harmless since the final conversion is only a reinterpretation
+ of the bit pattern.
+
??? 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));
+ tree rtype
+ = gnat_type_for_mode (TYPE_MODE (type), !TYPE_UNSIGNED (etype));
rtype = copy_type (rtype);
TYPE_MAIN_VARIANT (rtype) = rtype;
TREE_TYPE (rtype) = type;
- final_unchecked = true;
+ expr = convert (rtype, expr);
+ expr = build1 (VIEW_CONVERT_EXPR, type, expr);
}
- 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 = 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
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);
OSDN Git Service
