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. */
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)
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
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);
}
\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;
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)
{
/* 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);
/* 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. */
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)
|| (code == INTEGER_CST && ecode == INTEGER_CST
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;
OSDN Git Service
