static tree convert_to_thin_pointer (tree, tree);
static tree make_descriptor_field (const char *,tree, tree, tree);
static bool potential_alignment_gap (tree, tree, tree);
-static void process_attributes (tree, struct attrib *);
\f
/* Initialize the association of GNAT nodes to GCC trees. */
TYPE_DUMMY_P (gnu_type) = 1;
TYPE_STUB_DECL (gnu_type)
= create_type_stub_decl (TYPE_NAME (gnu_type), gnu_type);
- if (Is_By_Reference_Type (gnat_type))
- TREE_ADDRESSABLE (gnu_type) = 1;
+ if (AGGREGATE_TYPE_P (gnu_type))
+ TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_type);
SET_DUMMY_NODE (gnat_underlying, gnu_type);
return ((force_global || !current_function_decl) ? -1 : 0);
}
-/* Enter a new binding level. */
+/* Enter a new binding level. */
void
gnat_pushlevel (void)
if (current_binding_level)
BLOCK_SUPERCONTEXT (newlevel->block) = current_binding_level->block;
- BLOCK_VARS (newlevel->block) = NULL_TREE;
- BLOCK_SUBBLOCKS (newlevel->block) = NULL_TREE;
+ BLOCK_VARS (newlevel->block) = BLOCK_SUBBLOCKS (newlevel->block) = NULL_TREE;
TREE_USED (newlevel->block) = 1;
- /* Add this level to the front of the chain (stack) of active levels. */
+ /* Add this level to the front of the chain (stack) of levels that are
+ active. */
newlevel->chain = current_binding_level;
newlevel->jmpbuf_decl = NULL_TREE;
current_binding_level = newlevel;
{
BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
DECL_INITIAL (fndecl) = current_binding_level->block;
- set_block_for_group (current_binding_level->block);
}
/* Set the jmpbuf_decl for the current binding level to DECL. */
return current_binding_level->jmpbuf_decl;
}
-/* Exit a binding level. Set any BLOCK into the current code group. */
+/* Exit a binding level. Set any BLOCK into the current code group. */
void
gnat_poplevel (void)
/* If this is a function-level BLOCK don't do anything. Otherwise, if there
are no variables free the block and merge its subblocks into those of its
- parent block. Otherwise, add it to the list of its parent. */
+ parent block. Otherwise, add it to the list of its parent. */
if (TREE_CODE (BLOCK_SUPERCONTEXT (block)) == FUNCTION_DECL)
;
else if (BLOCK_VARS (block) == NULL_TREE)
}
}
\f
+/* Do little here. Set up the standard declarations later after the
+ front end has been run. */
+
+void
+gnat_init_decl_processing (void)
+{
+ /* Make the binding_level structure for global names. */
+ current_function_decl = 0;
+ current_binding_level = 0;
+ free_binding_level = 0;
+ gnat_pushlevel ();
+
+ build_common_tree_nodes (true, true);
+
+ /* In Ada, we use a signed type for SIZETYPE. Use the signed type
+ 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_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);
+}
+\f
/* Record TYPE as a builtin type for Ada. NAME is the name of the type. */
void
align = tree_low_cst (TREE_OPERAND (curpos, 1), 1);
/* An offset which is a bitwise AND with a negative power of 2
- means an alignment corresponding to this power of 2. Note
- that, as sizetype is sign-extended but nonetheless unsigned,
- we don't directly use tree_int_cst_sgn. */
+ means an alignment corresponding to this power of 2. */
offset = remove_conversions (offset, true);
if (TREE_CODE (offset) == BIT_AND_EXPR
&& host_integerp (TREE_OPERAND (offset, 1), 0)
- && TREE_INT_CST_HIGH (TREE_OPERAND (offset, 1)) < 0)
+ && tree_int_cst_sgn (TREE_OPERAND (offset, 1)) < 0)
{
unsigned int pow
= - tree_low_cst (TREE_OPERAND (offset, 1), 0);
field_name = concat_name (field_name, suffix);
}
- new_field
- = create_field_decl (field_name, field_type, new_record_type,
- DECL_SIZE (old_field), pos, 0, 0);
+ new_field = create_field_decl (field_name, field_type,
+ new_record_type, 0,
+ DECL_SIZE (old_field), pos, 0);
TREE_CHAIN (new_field) = TYPE_FIELDS (new_record_type);
TYPE_FIELDS (new_record_type) = new_field;
TYPE_DECL, type_name, type);
DECL_ARTIFICIAL (type_decl) = artificial_p;
-
- /* Add this decl to the current binding level. */
gnat_pushdecl (type_decl, gnat_node);
-
process_attributes (type_decl, attr_list);
/* If we're naming the type, equate the TYPE_STUB_DECL to the name.
!= null_pointer_node)
DECL_IGNORED_P (var_decl) = 1;
+ 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);
if (TREE_SIDE_EFFECTS (var_decl))
TREE_ADDRESSABLE (var_decl) = 1;
- if (TREE_CODE (var_decl) == VAR_DECL)
+ if (TREE_CODE (var_decl) != CONST_DECL)
{
- if (asm_name)
- SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
- process_attributes (var_decl, attr_list);
if (global_bindings_p ())
rest_of_decl_compilation (var_decl, true, 0);
}
}
/* 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. If SIZE is
- nonzero, it is the specified size of the field. If POS is nonzero, it is
- the bit position. PACKED is 1 if the enclosing record is packed, -1 if it
- has Component_Alignment of Storage_Unit. If ADDRESSABLE is nonzero, it
+ 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,
- tree size, tree pos, int packed, int addressable)
+ int packed, tree size, tree pos, int addressable)
{
tree field_decl = build_decl (input_location,
FIELD_DECL, field_name, field_type);
\f
/* Given a DECL and ATTR_LIST, process the listed attributes. */
-static void
+void
process_attributes (tree decl, struct attrib *attr_list)
{
for (; attr_list; attr_list = attr_list->next)
switch (attr_list->type)
{
case ATTR_MACHINE_ATTRIBUTE:
- input_location = DECL_SOURCE_LOCATION (decl);
decl_attributes (&decl, tree_cons (attr_list->name, attr_list->args,
NULL_TREE),
ATTR_FLAG_TYPE_IN_PLACE);
DECL_NAME (subprog_decl) = main_identifier_node;
}
+ process_attributes (subprog_decl, attr_list);
+
/* Add this decl to the current binding level. */
gnat_pushdecl (subprog_decl, gnat_node);
- process_attributes (subprog_decl, attr_list);
-
/* Output the assembler code and/or RTL for the declaration. */
rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0);
{
tree param_decl;
- announce_function (subprog_decl);
-
current_function_decl = subprog_decl;
+ announce_function (subprog_decl);
/* Enter a new binding level and show that all the parameters belong to
this function. */
gnat_pushlevel ();
-
for (param_decl = DECL_ARGUMENTS (subprog_decl); param_decl;
param_decl = TREE_CHAIN (param_decl))
DECL_CONTEXT (param_decl) = subprog_decl;
/* Mark the BLOCK for this level as being for this function and pop the
level. Since the vars in it are the parameters, clear them. */
- BLOCK_VARS (current_binding_level->block) = NULL_TREE;
+ BLOCK_VARS (current_binding_level->block) = 0;
BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
DECL_INITIAL (fndecl) = current_binding_level->block;
gnat_poplevel ();
DECL_SAVED_TREE (fndecl) = body;
current_function_decl = DECL_CONTEXT (fndecl);
+ set_cfun (NULL);
/* We cannot track the location of errors past this point. */
error_gnat_node = Empty;
if (code == COMPOUND_EXPR)
return max_size (TREE_OPERAND (exp, 1), max_p);
+ /* Calculate "(A ? B : C) - D" as "A ? B - D : C - D" which
+ may provide a tighter bound on max_size. */
+ if (code == MINUS_EXPR
+ && TREE_CODE (TREE_OPERAND (exp, 0)) == COND_EXPR)
+ {
+ tree lhs = fold_build2 (MINUS_EXPR, type,
+ TREE_OPERAND (TREE_OPERAND (exp, 0), 1),
+ TREE_OPERAND (exp, 1));
+ tree rhs = fold_build2 (MINUS_EXPR, type,
+ TREE_OPERAND (TREE_OPERAND (exp, 0), 2),
+ TREE_OPERAND (exp, 1));
+ return fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type,
+ max_size (lhs, max_p),
+ max_size (rhs, max_p));
+ }
+
{
tree lhs = max_size (TREE_OPERAND (exp, 0), max_p);
tree rhs = max_size (TREE_OPERAND (exp, 1),
In that case, if one side overflows, return the other.
sizetype is signed, but we know sizes are non-negative.
Likewise, handle a MINUS_EXPR or PLUS_EXPR with the LHS
- overflowing and the RHS a variable. */
+ overflowing or the maximum possible value and the RHS
+ a variable. */
if (max_p
&& code == MIN_EXPR
&& TREE_CODE (rhs) == INTEGER_CST
&& TREE_OVERFLOW (lhs))
return rhs;
else if ((code == MINUS_EXPR || code == PLUS_EXPR)
- && TREE_CODE (lhs) == INTEGER_CST
- && TREE_OVERFLOW (lhs)
+ && ((TREE_CODE (lhs) == INTEGER_CST
+ && TREE_OVERFLOW (lhs))
+ || operand_equal_p (lhs, TYPE_MAX_VALUE (type), 0))
&& !TREE_CONSTANT (rhs))
return lhs;
else
return gnat_build_constructor (template_type, nreverse (template_elts));
}
\f
-/* Build a 32-bit VMS descriptor from a Mechanism_Type, which must specify a
- descriptor type, and the GCC type of an object. Each FIELD_DECL in the
- type contains in its DECL_INITIAL the expression to use when a constructor
- is made for the type. GNAT_ENTITY is an entity used to print out an error
- message if the mechanism cannot be applied to an object of that type and
- also for the name. */
+/* Build a 32bit VMS descriptor from a Mechanism_Type, which must specify
+ a descriptor type, and the GCC type of an object. Each FIELD_DECL
+ in the type contains in its DECL_INITIAL the expression to use when
+ a constructor is made for the type. GNAT_ENTITY is an entity used
+ to print out an error message if the mechanism cannot be applied to
+ an object of that type and also for the name. */
tree
build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
break;
}
- /* Make the type for a descriptor for VMS. The first four fields are the
- same for all types. */
- field_list
- = chainon (field_list,
- make_descriptor_field ("LENGTH", gnat_type_for_size (16, 1),
- record_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", gnat_type_for_size (8, 1),
- record_type, size_int (dtype)));
+ /* Make the type for a descriptor for VMS. The first four fields
+ are the same for all types. */
+
field_list
= chainon (field_list,
- make_descriptor_field ("CLASS", gnat_type_for_size (8, 1),
- record_type, size_int (klass)));
+ make_descriptor_field
+ ("LENGTH", gnat_type_for_size (16, 1), record_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",
+ gnat_type_for_size (8, 1),
+ record_type, size_int (dtype)));
+ field_list = chainon (field_list,
+ make_descriptor_field ("CLASS",
+ gnat_type_for_size (8, 1),
+ 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. */
field_list
= chainon (field_list,
- make_descriptor_field ("POINTER", pointer32_type, record_type,
- build_unary_op (ADDR_EXPR,
- pointer32_type,
- build0 (PLACEHOLDER_EXPR,
- type))));
+ make_descriptor_field
+ ("POINTER", pointer32_type, record_type,
+ build_unary_op (ADDR_EXPR,
+ pointer32_type,
+ build0 (PLACEHOLDER_EXPR, type))));
switch (mech)
{
return record_type;
}
-/* Build a 64-bit VMS descriptor from a Mechanism_Type, which must specify a
- descriptor type, and the GCC type of an object. Each FIELD_DECL in the
- type contains in its DECL_INITIAL the expression to use when a constructor
- is made for the type. GNAT_ENTITY is an entity used to print out an error
- message if the mechanism cannot be applied to an object of that type and
- also for the name. */
+/* Build a 64bit VMS descriptor from a Mechanism_Type, which must specify
+ a descriptor type, and the GCC type of an object. Each FIELD_DECL
+ in the type contains in its DECL_INITIAL the expression to use when
+ a constructor is made for the type. GNAT_ENTITY is an entity used
+ to print out an error message if the mechanism cannot be applied to
+ an object of that type and also for the name. */
tree
build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
break;
}
- /* Make the type for a 64-bit descriptor for VMS. The first six fields
+ /* Make the type for a 64bit descriptor for VMS. The first six fields
are the same for all types. */
+
+ field_list64 = chainon (field_list64,
+ make_descriptor_field ("MBO",
+ gnat_type_for_size (16, 1),
+ record64_type, size_int (1)));
+
+ field_list64 = chainon (field_list64,
+ make_descriptor_field ("DTYPE",
+ gnat_type_for_size (8, 1),
+ record64_type, size_int (dtype)));
+ field_list64 = chainon (field_list64,
+ make_descriptor_field ("CLASS",
+ gnat_type_for_size (8, 1),
+ record64_type, size_int (klass)));
+
+ field_list64 = chainon (field_list64,
+ make_descriptor_field ("MBMO",
+ gnat_type_for_size (32, 1),
+ record64_type, ssize_int (-1)));
+
field_list64
= chainon (field_list64,
- make_descriptor_field ("MBO", gnat_type_for_size (16, 1),
- record64_type, size_int (1)));
- field_list64
- = chainon (field_list64,
- make_descriptor_field ("DTYPE", gnat_type_for_size (8, 1),
- record64_type, size_int (dtype)));
- field_list64
- = chainon (field_list64,
- make_descriptor_field ("CLASS", gnat_type_for_size (8, 1),
- record64_type, size_int (klass)));
- field_list64
- = chainon (field_list64,
- make_descriptor_field ("MBMO", gnat_type_for_size (32, 1),
- record64_type, ssize_int (-1)));
- field_list64
- = chainon (field_list64,
- make_descriptor_field ("LENGTH", gnat_type_for_size (64, 1),
- record64_type,
- size_in_bytes (mech == By_Descriptor_A
- ? inner_type : type)));
+ make_descriptor_field
+ ("LENGTH", gnat_type_for_size (64, 1), record64_type,
+ size_in_bytes (mech == By_Descriptor_A ? inner_type : type)));
pointer64_type = build_pointer_type_for_mode (type, DImode, false);
field_list64
= chainon (field_list64,
- make_descriptor_field ("POINTER", pointer64_type,
- record64_type,
- build_unary_op (ADDR_EXPR,
- pointer64_type,
- build0 (PLACEHOLDER_EXPR,
- type))));
+ make_descriptor_field
+ ("POINTER", pointer64_type, record64_type,
+ build_unary_op (ADDR_EXPR,
+ pointer64_type,
+ build0 (PLACEHOLDER_EXPR, type))));
switch (mech)
{
tree rec_type, tree initial)
{
tree field
- = create_field_decl (get_identifier (name), type, rec_type, NULL_TREE,
- NULL_TREE, 0, 0);
+ = create_field_decl (get_identifier (name), type, rec_type, 0, 0, 0, 0);
DECL_INITIAL (field) = initial;
return field;
/* 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 pointer = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (klass)));
+ tree pointer64 = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (klass)));
/* Retrieve the value of the POINTER field. */
tree gnu_expr64
- = build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE);
+ = build3 (COMPONENT_REF, TREE_TYPE (pointer64), desc, pointer64, NULL_TREE);
if (POINTER_TYPE_P (gnu_type))
return convert (gnu_type, gnu_expr64);
int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass));
tree lfield, ufield;
- /* Convert POINTER to the pointer-to-array type. */
+ /* Convert POINTER to the type of the P_ARRAY field. */
gnu_expr64 = convert (p_array_type, gnu_expr64);
switch (iklass)
/* 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, boolean_type_node, t, u);
+ 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 (pointer);
+ t = TREE_CHAIN (pointer64);
lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE);
lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield);
case 4: /* Class A */
/* The AFLAGS field is the 3rd field after the pointer in the
descriptor. */
- t = TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (pointer)));
+ 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. */
/* 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, boolean_type_node,
- build_binary_op (NE_EXPR, boolean_type_node,
+ 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, boolean_type_node,
+ build_binary_op (NE_EXPR, integer_type_node,
build2 (BIT_AND_EXPR,
TREE_TYPE (aflags),
aflags, u),
/* See the head comment of build_vms_descriptor. */
int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass));
- /* Convert POINTER to the pointer-to-array type. */
+ /* Convert POINTER to the type of the P_ARRAY field. */
gnu_expr32 = convert (p_array_type, gnu_expr32);
switch (iklass)
/* 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, boolean_type_node, t, u);
+ 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);
/* 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, boolean_type_node,
- build_binary_op (NE_EXPR, boolean_type_node,
+ 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, boolean_type_node,
+ build_binary_op (NE_EXPR, integer_type_node,
build2 (BIT_AND_EXPR,
TREE_TYPE (aflags),
aflags, u),
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, boolean_type_node,
- build_binary_op (EQ_EXPR, boolean_type_node,
+ = 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, boolean_type_node,
+ build_binary_op (EQ_EXPR, integer_type_node,
convert (integer_type_node, mbmo),
integer_minus_one_node));
end_subprog_body (gnu_body);
}
\f
-/* Build a type to be used to represent an aliased object whose nominal type
- is an unconstrained array. This consists of a RECORD_TYPE containing a
- field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an ARRAY_TYPE.
- If ARRAY_TYPE is that of an unconstrained array, this is used to represent
- an arbitrary unconstrained object. Use NAME as the name of the record.
- DEBUG_INFO_P is true if we need to write debug information for the type. */
+/* Build a type to be used to represent an aliased object whose nominal
+ type is an unconstrained array. This consists of a RECORD_TYPE containing
+ a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an
+ ARRAY_TYPE. If ARRAY_TYPE is that of the unconstrained array, this
+ is used to represent an arbitrary unconstrained object. Use NAME
+ as the name of the record. */
tree
-build_unc_object_type (tree template_type, tree object_type, tree name,
- bool debug_info_p)
+build_unc_object_type (tree template_type, tree object_type, tree name)
{
tree type = make_node (RECORD_TYPE);
- tree template_field
- = create_field_decl (get_identifier ("BOUNDS"), template_type, type,
- NULL_TREE, NULL_TREE, 0, 1);
- tree array_field
- = create_field_decl (get_identifier ("ARRAY"), object_type, type,
- NULL_TREE, NULL_TREE, 0, 1);
+ tree template_field = create_field_decl (get_identifier ("BOUNDS"),
+ template_type, type, 0, 0, 0, 1);
+ tree array_field = create_field_decl (get_identifier ("ARRAY"), object_type,
+ type, 0, 0, 0, 1);
TYPE_NAME (type) = name;
TYPE_CONTAINS_TEMPLATE_P (type) = 1;
- TREE_CHAIN (template_field) = array_field;
- finish_record_type (type, template_field, 0, true);
-
- /* Declare it now since it will never be declared otherwise. This is
- necessary to ensure that its subtrees are properly marked. */
- create_type_decl (name, type, NULL, true, debug_info_p, Empty);
+ finish_record_type (type,
+ chainon (chainon (NULL_TREE, template_field),
+ array_field),
+ 0, true);
return type;
}
tree
build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type,
- tree name, bool debug_info_p)
+ tree name)
{
tree template_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, debug_info_p);
+ return build_unc_object_type (template_type, object_type, name);
}
/* Shift the component offsets within an unconstrained object TYPE to make it
{
tree fields = TYPE_FIELDS (TREE_TYPE (etype));
- expr = gnat_protect_expr (expr);
+ expr = protect_multiple_eval (expr);
if (TREE_CODE (expr) == ADDR_EXPR)
expr = TREE_OPERAND (expr, 0);
else
tree
convert (tree type, tree expr)
{
+ enum tree_code code = TREE_CODE (type);
tree etype = TREE_TYPE (expr);
enum tree_code ecode = TREE_CODE (etype);
- enum tree_code code = TREE_CODE (type);
- /* If the expression is already of the right type, we are done. */
- if (etype == type)
+ /* If EXPR is already the right type, we are done. */
+ if (type == etype)
return expr;
/* If both input and output have padding and are of variable size, do this
/* 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 (ecode == RECORD_TYPE
+ if (TREE_CODE (etype) == RECORD_TYPE
&& CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type))))
{
if (TREE_CONSTANT (TYPE_SIZE (etype)))
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 (ecode == ARRAY_TYPE
+ 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 expr;
}
- /* Likewise for a conversion between original and packable version, or
- conversion between types of the same size and with the same list of
- fields, but we have to work harder to preserve type consistency. */
+ /* Likewise for a conversion between original and packable version, but
+ we have to work harder in order to preserve type consistency. */
if (code == ecode
&& code == RECORD_TYPE
- && (TYPE_NAME (type) == TYPE_NAME (etype)
- || tree_int_cst_equal (TYPE_SIZE (type), TYPE_SIZE (etype))))
-
+ && TYPE_NAME (type) == TYPE_NAME (etype))
{
VEC(constructor_elt,gc) *e = CONSTRUCTOR_ELTS (expr);
unsigned HOST_WIDE_INT len = VEC_length (constructor_elt, e);
FOR_EACH_CONSTRUCTOR_ELT(e, idx, index, value)
{
- constructor_elt *elt;
- /* We expect only simple constructors. */
- if (!SAME_FIELD_P (index, efield))
- break;
- /* The field must be the same. */
- if (!SAME_FIELD_P (efield, field))
+ constructor_elt *elt = VEC_quick_push (constructor_elt, v, NULL);
+ /* We expect only simple constructors. Otherwise, punt. */
+ if (!(index == efield || index == DECL_ORIGINAL_FIELD (efield)))
break;
- elt = VEC_quick_push (constructor_elt, v, NULL);
elt->index = field;
elt->value = convert (TREE_TYPE (field), value);
case UNCONSTRAINED_ARRAY_REF:
/* Convert this to the type of the inner array by getting the address of
the array from the template. */
- expr = TREE_OPERAND (expr, 0);
expr = build_unary_op (INDIRECT_REF, NULL_TREE,
- build_component_ref (expr, NULL_TREE,
- TYPE_FIELDS
- (TREE_TYPE (expr)),
- false));
+ build_component_ref (TREE_OPERAND (expr, 0),
+ get_identifier ("P_ARRAY"),
+ NULL_TREE, false));
etype = TREE_TYPE (expr);
ecode = TREE_CODE (etype);
break;
}
break;
+ case INDIRECT_REF:
+ /* If both types are record types, just convert the pointer and
+ make a new INDIRECT_REF.
+
+ ??? Disable this for now since it causes problems with the
+ code in build_binary_op for MODIFY_EXPR which wants to
+ strip off conversions. But that code really is a mess and
+ we need to do this a much better way some time. */
+ if (0
+ && (TREE_CODE (type) == RECORD_TYPE
+ || TREE_CODE (type) == UNION_TYPE)
+ && (TREE_CODE (etype) == RECORD_TYPE
+ || TREE_CODE (etype) == UNION_TYPE)
+ && !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)));
+ break;
+
default:
break;
}
etype)))
return build1 (VIEW_CONVERT_EXPR, type, expr);
- /* If we are converting between tagged types, try to upcast properly. */
- else if (ecode == RECORD_TYPE && code == RECORD_TYPE
- && TYPE_ALIGN_OK (etype) && TYPE_ALIGN_OK (type))
- {
- tree child_etype = etype;
- do {
- tree field = TYPE_FIELDS (child_etype);
- if (DECL_NAME (field) == parent_name_id && TREE_TYPE (field) == type)
- return build_component_ref (expr, NULL_TREE, field, false);
- child_etype = TREE_TYPE (field);
- } while (TREE_CODE (child_etype) == RECORD_TYPE);
- }
-
/* In all other cases of related types, make a NOP_EXPR. */
- else if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype))
+ else if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype)
+ || (code == INTEGER_CST && ecode == INTEGER_CST
+ && (type == TREE_TYPE (etype) || etype == TREE_TYPE (type))))
return fold_convert (type, expr);
switch (code)
tree bit_diff
= size_diffop (bit_position (TYPE_FIELDS (TREE_TYPE (etype))),
bit_position (TYPE_FIELDS (TREE_TYPE (type))));
- tree byte_diff
- = size_binop (CEIL_DIV_EXPR, bit_diff, sbitsize_unit_node);
+ tree byte_diff = size_binop (CEIL_DIV_EXPR, bit_diff,
+ sbitsize_int (BITS_PER_UNIT));
+
expr = build1 (NOP_EXPR, type, expr);
TREE_CONSTANT (expr) = TREE_CONSTANT (TREE_OPERAND (expr, 0));
if (integer_zerop (byte_diff))
/* If converting fat pointer to normal pointer, get the pointer to the
array and then convert it. */
else if (TYPE_IS_FAT_POINTER_P (etype))
- expr
- = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (etype), false);
+ expr = build_component_ref (expr, get_identifier ("P_ARRAY"),
+ NULL_TREE, false);
return fold (convert_to_pointer (type, expr));
}
\f
/* If EXP's type is an UNCONSTRAINED_ARRAY_TYPE, return an expression that
- refers to the underlying array. If it has TYPE_CONTAINS_TEMPLATE_P,
+ refers to the underlying array. If its type has TYPE_CONTAINS_TEMPLATE_P,
likewise return an expression pointing to the underlying array. */
tree
case UNCONSTRAINED_ARRAY_TYPE:
if (code == UNCONSTRAINED_ARRAY_REF)
{
- new_exp = TREE_OPERAND (exp, 0);
new_exp
= build_unary_op (INDIRECT_REF, NULL_TREE,
- build_component_ref (new_exp, NULL_TREE,
- TYPE_FIELDS
- (TREE_TYPE (new_exp)),
- false));
+ build_component_ref (TREE_OPERAND (exp, 0),
+ get_identifier ("P_ARRAY"),
+ NULL_TREE, false));
TREE_READONLY (new_exp) = TREE_READONLY (exp);
return new_exp;
}
build_component_ref (new_exp, NULL_TREE,
TREE_CHAIN
(TYPE_FIELDS (TREE_TYPE (new_exp))),
- false);
+ 0);
}
else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp)))
return
build_component_ref (exp, NULL_TREE,
- TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))),
- false);
+ TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))), 0);
break;
default:
unchecked_convert (tree type, tree expr, bool notrunc_p)
{
tree etype = TREE_TYPE (expr);
- enum tree_code ecode = TREE_CODE (etype);
- enum tree_code code = TREE_CODE (type);
- /* If the expression is already of the right type, we are done. */
+ /* If the expression is already the right type, we are done. */
if (etype == type)
return expr;
/* If both types types are integral just do a normal conversion.
Likewise for a conversion to an unconstrained array. */
if ((((INTEGRAL_TYPE_P (type)
- && !(code == INTEGER_TYPE && TYPE_VAX_FLOATING_POINT_P (type)))
+ && !(TREE_CODE (type) == INTEGER_TYPE
+ && TYPE_VAX_FLOATING_POINT_P (type)))
|| (POINTER_TYPE_P (type) && ! TYPE_IS_THIN_POINTER_P (type))
- || (code == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (type)))
+ || (TREE_CODE (type) == RECORD_TYPE
+ && TYPE_JUSTIFIED_MODULAR_P (type)))
&& ((INTEGRAL_TYPE_P (etype)
- && !(ecode == INTEGER_TYPE && TYPE_VAX_FLOATING_POINT_P (etype)))
+ && !(TREE_CODE (etype) == INTEGER_TYPE
+ && TYPE_VAX_FLOATING_POINT_P (etype)))
|| (POINTER_TYPE_P (etype) && !TYPE_IS_THIN_POINTER_P (etype))
- || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype))))
- || code == UNCONSTRAINED_ARRAY_TYPE)
+ || (TREE_CODE (etype) == RECORD_TYPE
+ && TYPE_JUSTIFIED_MODULAR_P (etype))))
+ || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
{
- if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
+ if (TREE_CODE (etype) == INTEGER_TYPE
+ && TYPE_BIASED_REPRESENTATION_P (etype))
{
tree ntype = copy_type (etype);
TYPE_BIASED_REPRESENTATION_P (ntype) = 0;
expr = build1 (NOP_EXPR, ntype, expr);
}
- if (code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type))
+ if (TREE_CODE (type) == INTEGER_TYPE
+ && TYPE_BIASED_REPRESENTATION_P (type))
{
tree rtype = copy_type (type);
TYPE_BIASED_REPRESENTATION_P (rtype) = 0;
GET_MODE_BITSIZE (TYPE_MODE (type))))
{
tree rec_type = make_node (RECORD_TYPE);
- tree field = create_field_decl (get_identifier ("OBJ"), type, rec_type,
- NULL_TREE, NULL_TREE, 1, 0);
+ tree field = create_field_decl (get_identifier ("OBJ"), type,
+ rec_type, 1, 0, 0, 0);
TYPE_FIELDS (rec_type) = field;
layout_type (rec_type);
expr = unchecked_convert (rec_type, expr, notrunc_p);
- expr = build_component_ref (expr, NULL_TREE, field, false);
+ expr = build_component_ref (expr, NULL_TREE, field, 0);
}
/* Similarly if we are converting from an integral type whose precision
GET_MODE_BITSIZE (TYPE_MODE (etype))))
{
tree rec_type = make_node (RECORD_TYPE);
- tree field = create_field_decl (get_identifier ("OBJ"), etype, rec_type,
- NULL_TREE, NULL_TREE, 1, 0);
+ tree field
+ = create_field_decl (get_identifier ("OBJ"), etype, rec_type,
+ 1, 0, 0, 0);
TYPE_FIELDS (rec_type) = field;
layout_type (rec_type);
/* 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 (ecode == code && code == UNCONSTRAINED_ARRAY_TYPE)
+ 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,
/* Another special case is when we are converting to a vector type from its
representative array type; this a regular conversion. */
- else if (code == VECTOR_TYPE
- && ecode == ARRAY_TYPE
+ 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);
{
expr = maybe_unconstrained_array (expr);
etype = TREE_TYPE (expr);
- ecode = TREE_CODE (etype);
if (can_fold_for_view_convert_p (expr))
expr = fold_build1 (VIEW_CONVERT_EXPR, type, expr);
else
is a biased type or if both the input and output are unsigned. */
if (!notrunc_p
&& INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type)
- && !(code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type))
+ && !(TREE_CODE (type) == INTEGER_TYPE
+ && TYPE_BIASED_REPRESENTATION_P (type))
&& 0 != compare_tree_int (TYPE_RM_SIZE (type),
GET_MODE_BITSIZE (TYPE_MODE (type)))
&& !(INTEGRAL_TYPE_P (etype)
0))
&& !(TYPE_UNSIGNED (type) && TYPE_UNSIGNED (etype)))
{
- tree base_type
- = gnat_type_for_mode (TYPE_MODE (type), TYPE_UNSIGNED (type));
+ tree base_type = gnat_type_for_mode (TYPE_MODE (type),
+ TYPE_UNSIGNED (type));
tree shift_expr
= convert (base_type,
size_binop (MINUS_EXPR,
static void
install_builtin_elementary_types (void)
{
- signed_size_type_node = gnat_signed_type (size_type_node);
+ signed_size_type_node = size_type_node;
pid_type_node = integer_type_node;
void_list_node = build_void_list_node ();
if (!argument
|| TREE_CODE (TREE_VALUE (argument)) == VOID_TYPE)
{
- error ("nonnull argument with out-of-range operand number "
- "(argument %lu, operand %lu)",
+ error ("nonnull argument with out-of-range operand number (argument %lu, operand %lu)",
(unsigned long) attr_arg_num, (unsigned long) arg_num);
*no_add_attrs = true;
return NULL_TREE;
if (TREE_CODE (TREE_VALUE (argument)) != POINTER_TYPE)
{
- error ("nonnull argument references non-pointer operand "
- "(argument %lu, operand %lu)",
+ error ("nonnull argument references non-pointer operand (argument %lu, operand %lu)",
(unsigned long) attr_arg_num, (unsigned long) arg_num);
*no_add_attrs = true;
return NULL_TREE;