}
/* Otherwise, the base types must be the same unless the objects are
- records. If we have records, use the best type and convert both
- operands to that type. */
+ fat pointers or records. If we have records, use the best type and
+ convert both operands to that type. */
if (left_base_type != right_base_type)
{
- if (TREE_CODE (left_base_type) == RECORD_TYPE
- && TREE_CODE (right_base_type) == RECORD_TYPE)
+ if (TYPE_FAT_POINTER_P (left_base_type)
+ && TYPE_FAT_POINTER_P (right_base_type)
+ && TYPE_MAIN_VARIANT (left_base_type)
+ == TYPE_MAIN_VARIANT (right_base_type))
+ best_type = left_base_type;
+ else if (TREE_CODE (left_base_type) == RECORD_TYPE
+ && TREE_CODE (right_base_type) == RECORD_TYPE)
{
/* The only way these are permitted to be the same is if both
types have the same name. In that case, one of them must
not be self-referential. Use that one as the best type.
Even better is if one is of fixed size. */
- best_type = NULL_TREE;
-
gcc_assert (TYPE_NAME (left_base_type)
&& (TYPE_NAME (left_base_type)
== TYPE_NAME (right_base_type)));
best_type = right_base_type;
else
gcc_unreachable ();
-
- left_operand = convert (best_type, left_operand);
- right_operand = convert (best_type, right_operand);
}
else
gcc_unreachable ();
+
+ left_operand = convert (best_type, left_operand);
+ right_operand = convert (best_type, right_operand);
}
/* If we are comparing a fat pointer against zero, we need to
GNAT_NODE is the gnat node conveying the source location for which the
error should be signaled, or Empty in which case the error is signaled on
- the current ref_file_name/input_line. */
+ the current ref_file_name/input_line.
+
+ KIND says which kind of exception this is for
+ (N_Raise_{Constraint,Storage,Program}_Error). */
tree
-build_call_raise (int msg, Node_Id gnat_node)
+build_call_raise (int msg, Node_Id gnat_node, char kind)
{
tree fndecl = gnat_raise_decls[msg];
+ tree label = get_exception_label (kind);
+ tree filename;
+ int line_number;
+ const char *str;
+ int len;
+
+ /* If this is to be done as a goto, handle that case. */
+ if (label)
+ {
+ Entity_Id local_raise = Get_Local_Raise_Call_Entity ();
+ tree gnu_result = build1 (GOTO_EXPR, void_type_node, label);
+
+ /* If Local_Raise is present, generate
+ Local_Raise (exception'Identity); */
+ if (Present (local_raise))
+ {
+ tree gnu_local_raise
+ = gnat_to_gnu_entity (local_raise, NULL_TREE, 0);
+ tree gnu_exception_entity
+ = gnat_to_gnu_entity (Get_RT_Exception_Entity (msg), NULL_TREE, 0);
+ tree gnu_call
+ = build_call_1_expr (gnu_local_raise,
+ build_unary_op (ADDR_EXPR, NULL_TREE,
+ gnu_exception_entity));
+
+ gnu_result = build2 (COMPOUND_EXPR, void_type_node,
+ gnu_call, gnu_result);}
+
+ return gnu_result;
+ }
- const char *str
+ str
= (Debug_Flag_NN || Exception_Locations_Suppressed)
? ""
- : (gnat_node != Empty)
+ : (gnat_node != Empty && Sloc (gnat_node) != No_Location)
? IDENTIFIER_POINTER
(get_identifier (Get_Name_String
(Debug_Source_Name
(Get_Source_File_Index (Sloc (gnat_node))))))
: ref_filename;
- int len = strlen (str) + 1;
- tree filename = build_string (len, str);
-
- int line_number
- = (gnat_node != Empty)
+ len = strlen (str) + 1;
+ filename = build_string (len, str);
+ line_number
+ = (gnat_node != Empty && Sloc (gnat_node) != No_Location)
? Get_Logical_Line_Number (Sloc(gnat_node)) : input_line;
TREE_TYPE (filename)
{
tree elmt1 = * (tree *) rt1;
tree elmt2 = * (tree *) rt2;
+ tree field1 = TREE_PURPOSE (elmt1);
+ tree field2 = TREE_PURPOSE (elmt2);
+ int ret;
- tree pos_field1 = bit_position (TREE_PURPOSE (elmt1));
- tree pos_field2 = bit_position (TREE_PURPOSE (elmt2));
-
- if (tree_int_cst_equal (pos_field1, pos_field2))
- return 0;
- else if (tree_int_cst_lt (pos_field1, pos_field2))
- return -1;
- else
- return 1;
+ ret = tree_int_cst_compare (bit_position (field1), bit_position (field2));
+ return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
}
/* Return a CONSTRUCTOR of TYPE whose list is LIST. */
/* For record types with constant components only, sort field list
by increasing bit position. This is necessary to ensure the
- constructor can be output as static data, which the gimplifier
- might force in various circumstances. */
+ constructor can be output as static data. */
if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1)
{
/* Fill an array with an element tree per index, and ask qsort to order
them according to what a bitpos comparison function says. */
-
tree *gnu_arr = (tree *) alloca (sizeof (tree) * n_elmts);
int i;
qsort (gnu_arr, n_elmts, sizeof (tree), compare_elmt_bitpos);
/* Then reconstruct the list from the sorted array contents. */
-
list = NULL_TREE;
for (i = n_elmts - 1; i >= 0; i--)
{
abort. */
gcc_assert (field);
return build1 (NULL_EXPR, TREE_TYPE (field),
- build_call_raise (CE_Discriminant_Check_Failed, Empty));
+ build_call_raise (CE_Discriminant_Check_Failed, Empty,
+ N_Raise_Constraint_Error));
}
\f
/* Build a GCC tree to call an allocation or deallocation function.
}
else if (gnu_obj)
- return build_call_1_expr (free_decl, gnu_obj);
+ {
+ /* If the required alignement was greater than what malloc guarantees,
+ what we have in gnu_obj here is an address dynamically adjusted to
+ match the requirement (see build_allocator). What we need to pass
+ to free is the initial underlying allocator's return value, which
+ has been stored just in front of the block we have. */
+ if (align > BIGGEST_ALIGNMENT)
+ {
+ /* We set GNU_OBJ
+ as * (void **)((void *)GNU_OBJ - (void *)sizeof(void *))
+ in two steps: */
+
+ /* GNU_OBJ (void *) = (void *)GNU_OBJ - (void *)sizeof (void *)) */
+ gnu_obj
+ = build_binary_op (MINUS_EXPR, ptr_void_type_node,
+ convert (ptr_void_type_node, gnu_obj),
+ convert (ptr_void_type_node,
+ TYPE_SIZE_UNIT (ptr_void_type_node)));
+
+ /* GNU_OBJ (void *) = *(void **)GNU_OBJ */
+ gnu_obj
+ = build_unary_op (INDIRECT_REF, NULL_TREE,
+ convert (build_pointer_type (ptr_void_type_node),
+ gnu_obj));
+ }
+
+ return build_call_1_expr (free_decl, gnu_obj);
+ }
/* ??? For now, disable variable-sized allocators in the stack since
we can't yet gimplify an ALLOCATE_EXPR. */
if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
size = ssize_int (-1);
- /* If this is a type whose alignment is larger than the
- biggest we support in normal alignment and this is in
- the default storage pool, make an "aligning type", allocate
- it, point to the field we need, and return that. */
- if (TYPE_ALIGN (type) > BIGGEST_ALIGNMENT
- && No (gnat_proc))
+ /* If this is a type whose alignment is larger than what the underlying
+ allocator supports and this is in the default storage pool, make an
+ "aligning" record type with room to store a pointer before the field,
+ allocate an object of that type, store the system's allocator return
+ value just in front of the field and return the field's address. */
+
+ if (TYPE_ALIGN (type) > BIGGEST_ALIGNMENT && No (gnat_proc))
{
- tree new_type = make_aligning_type (type, TYPE_ALIGN (type), size);
+ /* Construct the aligning type with enough room for a pointer ahead
+ of the field, then allocate. */
+ tree record_type
+ = make_aligning_type (type, TYPE_ALIGN (type), size,
+ BIGGEST_ALIGNMENT, POINTER_SIZE / BITS_PER_UNIT);
- result = build_call_alloc_dealloc (NULL_TREE, TYPE_SIZE_UNIT (new_type),
- BIGGEST_ALIGNMENT, Empty,
- Empty, gnat_node);
- result = save_expr (result);
- result = convert (build_pointer_type (new_type), result);
- result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
- result = build_component_ref (result, NULL_TREE,
- TYPE_FIELDS (new_type), 0);
- result = convert (result_type,
- build_unary_op (ADDR_EXPR, NULL_TREE, result));
+ tree record, record_addr;
+
+ record_addr
+ = build_call_alloc_dealloc (NULL_TREE, TYPE_SIZE_UNIT (record_type),
+ BIGGEST_ALIGNMENT, Empty, Empty,
+ gnat_node);
+
+ record_addr
+ = convert (build_pointer_type (record_type),
+ save_expr (record_addr));
+
+ record = build_unary_op (INDIRECT_REF, NULL_TREE, record_addr);
+
+ /* Our RESULT (the Ada allocator's value) is the super-aligned address
+ of the internal record field ... */
+ result
+ = build_unary_op (ADDR_EXPR, NULL_TREE,
+ build_component_ref
+ (record, NULL_TREE, TYPE_FIELDS (record_type), 0));
+ result = convert (result_type, result);
+
+ /* ... with the system allocator's return value stored just in
+ front. */
+ {
+ tree ptr_addr
+ = build_binary_op (MINUS_EXPR, ptr_void_type_node,
+ convert (ptr_void_type_node, result),
+ convert (ptr_void_type_node,
+ TYPE_SIZE_UNIT (ptr_void_type_node)));
+
+ tree ptr_ref
+ = convert (build_pointer_type (ptr_void_type_node), ptr_addr);
+
+ result
+ = build2 (COMPOUND_EXPR, TREE_TYPE (result),
+ build_binary_op (MODIFY_EXPR, NULL_TREE,
+ build_unary_op (INDIRECT_REF, NULL_TREE,
+ ptr_ref),
+ convert (ptr_void_type_node,
+ record_addr)),
+ result);
+ }
}
else
result = convert (result_type,
OSDN Git Service
