[Ada] Fix missing bits for proper gigi support in GCC 4
Arnaud Charlet
charlet@adacore.com
Tue Nov 15 14:31:00 GMT 2005
Tested on i686-linux, committed on trunk.
This change includes several important fixes related to the infrastructure
changes done in GCC 4.x that had not been accounted for in the Ada front-end,
in particular:
The size of record types is rounded up to the type's alignment using the
round_up function. Unlike in GCC 3.4 and earlier, it may now produce bit
manipulation expressions, in particular BIT_AND_EXPRs when the divisor is
a constant power of two.
Our back-annotation scheme was not ready to handle those expressions,
resulting in incorrect propagations for Container_Type in the testcase
below, visible as a single 'Size instead of differentiated 'Objcet_Size
and 'Value_Size in the -gnatR output.
The fix applied is to add support for BIT_AND_EXPR in annotate_value
and repinfo.
package P is
type Range_Type is range 1 .. 256;
type Bool_Array_Type is array (Range_Type range <>) of Boolean;
type Container_Type (N_Objects : Range_Type) is record
Mapped : Bool_Array_Type (1 .. N_Objects);
N_Instances : Integer;
end record;
end;
The -gnatR output is expected to read
for Container_Type'Value_Size use ??;
For record aggregates, annotate_rep propagates the final GCC components
size and position information back into the corresponding GNAT tree nodes.
The information for some inherited components was only propagated when
code generation was disabled (type_annotate_only), with unexpected effects
on the -gnatR outputs when code generation is enabled, and without specific
motivation.
The fix applied here is just to lift the type_annotate_only restriction on
the back-annotation of layout information for inherited components.
For the testcase below, ...
package P2 is
type Root (Control : Boolean) is abstract tagged limited null record;
type Derived is new Root with null record;
end;
The -c -gnatR3 compiler output is expected to include
<< for Derived use record
Control at 4 range 0 .. 7;
>>
instead of
<< for Derived use record
Control at ?? range 0 .. -1;
>>
Another problem was that no subtree of a record type defined in an external
package was marked as visited, so all subtrees of the type were effectively
shared in the compilation unit. When a DECL node is substituted in place
in one of these subtrees during the gimplification of a procedure, the new
node "belongs" to that procedure; now, since the subtrees are shared, it
will creep in into other procedures that reference the same subtree of the
type, leading to an ICE in the RTL expander.
It is triggered because gnat_to_gnu_entity invokes create_type_decl very
early when it is not processiong the definition of a record type, when the
type is essentially still a dummy type with no subtrees. The fix is simply
to get rid of these early invocations.
Also when processing a renaming entity, we avoid the introduction of unnecessary
indirections as much as possible and need a stabilized version of the renamed
object to that effect. So far, we were relying on assumptions about what
gnat_stabilize_reference is able to process, assumptions which turned out to
be not exactly right. In particular, a COMPONENT_REF applied to a CALL_EXPR
was assumed to be stabilizable while it is in fact not, which resulted in
erroneously returning it as is to act as the renaming entity. The net result
in such a case is that the function is incorrectly called every time the
renaming is used,
The fix is to stop relying on assumptions and extend the stabilizer interface
to let it indicate whether a stabilization has succeeded or not.
Besides, when attaching a renamed object to a renaming pointer for possible
direct use, we not only need to make sure that the object has been stabilized,
but also that it is an lvalue because the use context sometimes requires so.
This is addressed by a second extension of the stabilizer's interface, to
indicate whether we want it to stabilize lvalues only.
The extended interface is offered by a new function, maybe_stabilize_reference,
the implementation of which is based on the former stabilizer. The latter is
still available, now as a simple wrapper around the extended version.
The testcase below, compiled with checks on (no -gnatp) should output
"Returning one item ..." exactly once.
with Ada.Text_IO; use Ada.Text_IO;
procedure P is
type Integer_Access is access Integer;
type Item_T is record
Value : Integer_Access;
end record;
function One_Item return Item_T is
begin
Put_Line ("Returning one item ...");
return (Value => new Integer'(1));
end;
X : Integer;
begin
X := One_Item.Value.all;
end;
The flow-of-control was running into unbalanced incrementing and decrementing
of force_global because of this early return, causing global_bindings_p() to
always return true after some time, which in turns was seriously confusing
the nested subprograms handling code.
References (!definition) to an object with an address clause are turned
into indirect references by gigi, using a reference type. Such objects
might also have an initializing expression, which is meaningless in the
!definition case. gigi was however keeping that expression around and
trying to convert it to the reference type later on, leading to spurious
"cannot convert to a pointer type" errors in some cases.
The fix is to drop the useless initializing expression in such situations.
The testcase below should compile silently with -O0 and -O2:
with Lists;
procedure P is
E : Lists.Entry_T;
begin
null;
end;
with System.Storage_Elements;
package Lists is
subtype Key_T is String(1 .. 4);
Null_Key : constant Key_T := "0000";
for Null_Key'Address use System.Null_Address;
type Entry_T is record
Key : Key_T := Null_Key;
end record;
end;
This patch is also adding the necessary support code for No_Elaboration_Code
restrictions checks, which had not yet been transposed in this version
of gigi (targetted to the GCC 4.x series).
Compiling this testcase:
pragma Restrictions (No_Elaboration_Code);
package PB is
pragma Elaborate_Body;
end;
with Ada.Text_IO; use Ada.Text_IO;
package body PB is
begin
Put_Line ("elab code there");
end;
is expected to produce
pb.adb:5:04: violation of restriction "NO_ELABORATION_CODE" at pb.ads:1
2005-11-14 Thomas Quinot <quinot@adacore.com>
Olivier Hainque <hainque@adacore.com>
Eric Botcazou <ebotcazou@adacore.com>
* decl.c:
Factor common code to build a storage type for an unconstrained object
from a fat or thin pointer type and a constrained object type.
(annotate_value): Handle BIT_AND_EXPR.
(annotate_rep): Don't restrict the back annotation of inherited
components to the type_annotate_only case.
(gnat_to_gnu_entity) <E_Array_Type>: Do not invoke create_type_decl if
we are not defining the type.
<E_Record_Type>: Likewise.
(gnat_to_gnu_entity) <object, renaming>: Adjust comments and structure
to get advantage of the new maybe_stabilize_reference interface, to
ensure that what we reference is indeed stabilized instead of relying
on assumptions on what the stabilizer does.
(gnat_to_gnu_entity) <E_Incomplete_Type>: If the entity is an incomplete
type imported through a limited_with clause, use its non-limited view.
(Has_Stdcall_Convention): New macro, to centralize the Windows vs others
differentiation.
(gnat_to_gnu_entity): Use Has_Stdcall_Convention instead of a spread mix
of #if sections + explicit comparisons of convention identifiers.
(gnat_to_gnu_entity) <E_Variable>: Decrement force_global if necessary
before early-returning for certain types when code generation is
disabled.
(gnat_to_gnu_entity) <object>: Adjust comment attached to the
nullification of gnu_expr we do for objects with address clause and
that we are not defining.
(elaborate_expression_1): Do not create constants when creating
variables needed by the debug info: the dwarf2 writer considers that
CONST_DECLs is used only to represent enumeration constants, and emits
nothing for them.
(gnat_to_gnu_entity) <object>: When turning a non-definition of an
object with an address clause into an indirect reference, drop the
initializing expression.
Include "expr.h".
(STACK_CHECK_BUILTIN): Delete.
(STACK_CHECK_PROBE_INTERVAL): Likewise.
(STACK_CHECK_MAX_FRAME_SIZE): Likewise.
(STACK_CHECK_MAX_VAR_SIZE): Likewise.
(gnat_to_gnu_entity): If gnat_entity is a renaming, do not mark the tree
corresponding to the renamed object as ignored for debugging purposes.
* trans.c (tree_transform, case N_Attribute_Reference, case Attr_Size &
related): For a prefix that is a dereference of a fat or thin pointer,
if there is an actual subtype provided by the front-end, use that
subtype to build an actual type with bounds template.
(tree_transform, case N_Free_Statement): If an Actual_Designated_Subtype
is provided by the front-end, use that subtype to compute the size of
the deallocated object.
(gnat_to_gnu): When adding a statement into an elaboration procedure,
check for a potential violation of a No_Elaboration_Code restriction.
(maybe_stabilize_reference): New function, like gnat_stabilize_reference
with extra arguments to control whether to recurse through non-values
and to let the caller know if the stabilization has succeeded.
(gnat_stabilize_reference): Now a simple wrapper around
maybe_stabilize, for common uses without restriction on lvalues and
without need to check for the success indication.
(gnat_to_gnu, call_to_gnu): Adjust calls to gnat_stabilize_reference, to
pass false instead of 0 as the FORCE argument which is a bool.
(Identifier_to_gnu): Remove checks ensuring that an renamed object
attached to a renaming pointer has been properly stabilized, as no such
object is attached otherwise.
(call_to_gnu): Invoke create_var_decl to create the temporary when the
function uses the "target pointer" return mechanism.
Reinstate conversion of the actual to the type of the formal
parameter before any other specific treatment based on the passing
mechanism. This turns out to be necessary in order for PLACEHOLDER
substitution to work properly when the latter type is unconstrained.
* gigi.h (build_unc_object_type_from_ptr): New subprogram, factoring a
common pattern.
(maybe_stabilize_reference): New function, like gnat_stabilize_reference
with extra arguments to control whether to recurse through non-values
and to let the caller know if the stabilization has succeeded.
* utils2.c (gnat_build_constructor): Only sort the fields for possible
static output of record constructor if all the components are constant.
(gnat_build_constructor): For a record type, sort the list of field
initializers in increasing bit position order.
Factor common code to build a storage type for an unconstrained object
from a fat or thin pointer type and a constrained object type.
(build_unary_op) <ADDR_EXPR>: Always recurse down conversions between
types variants, and process special cases of VIEW_CONVERT expressions
as their NOP_EXPR counterpart to ensure we get to the
CORRESPONDING_VARs associated with CONST_DECls.
(build_binary_op) <MODIFY_EXPR>: Do not strip VIEW_CONVERT_EXPRs
on the right-hand side.
* utils.c (build_unc_object_type_from_ptr): New subprogram, factoring
a common pattern.
(convert) <VIEW_CONVERT_EXPR>: Return the inner operand directly if we
are converting back to its original type.
(convert) <JM input>: Fallthrough regular conversion code instead of
extracting the object if converting to a type variant.
(create_var_decl): When a variable has an initializer requiring code
generation and we are at the top level, check for a potential violation
of a No_Elaboration_Code restriction.
(create_var_decl): call expand_decl for CONST_DECLs, to set MODE, ALIGN
SIZE and SIZE_UNIT which we need for later back-annotations.
* utils.c: (convert) <STRING_CST>: Remove obsolete code.
<VIEW_CONVERT_EXPR>: Do not lift the conversion if the target type
is an unchecked union.
(pushdecl): Set DECL_NO_STATIC_CHAIN on imported nested functions.
(convert) <VIEW_CONVERT_EXPR>: When the types have the same
main variant, just replace the VIEW_CONVERT_EXPR.
<UNION_TYPE>: Revert 2005-03-02 change.
* repinfo.h, repinfo.ads: Add tcode for BIT_AND_EXPR.
* repinfo.adb (Print_Expr, Rep_Value): Handle Bit_And_Expressions.
-------------- next part --------------
Index: decl.c
===================================================================
--- decl.c (revision 106884)
+++ decl.c (working copy)
@@ -35,6 +35,7 @@
#include "ggc.h"
#include "obstack.h"
#include "target.h"
+#include "expr.h"
#include "ada.h"
#include "types.h"
@@ -52,22 +53,15 @@
#include "ada-tree.h"
#include "gigi.h"
-/* Provide default values for the macros controlling stack checking.
- This is copied from GCC's expr.h. */
+/* Convention_Stdcall should be processed in a specific way on Windows targets
+ only. The macro below is a helper to avoid having to check for a Windows
+ specific attribute throughout this unit. */
-#ifndef STACK_CHECK_BUILTIN
-#define STACK_CHECK_BUILTIN 0
+#if TARGET_DLLIMPORT_DECL_ATTRIBUTES
+#define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
+#else
+#define Has_Stdcall_Convention(E) (0)
#endif
-#ifndef STACK_CHECK_PROBE_INTERVAL
-#define STACK_CHECK_PROBE_INTERVAL 4096
-#endif
-#ifndef STACK_CHECK_MAX_FRAME_SIZE
-#define STACK_CHECK_MAX_FRAME_SIZE \
- (STACK_CHECK_PROBE_INTERVAL - UNITS_PER_WORD)
-#endif
-#ifndef STACK_CHECK_MAX_VAR_SIZE
-#define STACK_CHECK_MAX_VAR_SIZE (STACK_CHECK_MAX_FRAME_SIZE / 100)
-#endif
/* These two variables are used to defer recursively expanding incomplete
types while we are processing a record or subprogram type. */
@@ -531,6 +525,8 @@
|| TREE_CODE (gnu_type) == VOID_TYPE)
{
gcc_assert (type_annotate_only);
+ if (this_global)
+ force_global--;
return error_mark_node;
}
@@ -670,11 +666,9 @@
{
tree gnu_fat
= TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
- tree gnu_temp_type
- = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat))));
gnu_type
- = build_unc_object_type (gnu_temp_type, gnu_type,
+ = build_unc_object_type_from_ptr (gnu_fat, gnu_type,
concat_id_with_name (gnu_entity_id,
"UNC"));
}
@@ -729,19 +723,19 @@
(TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
gnu_expr = convert (gnu_type, gnu_expr);
- /* See if this is a renaming. If this is a constant renaming, treat
- it as a normal variable whose initial value is what is being
- renamed. We cannot do this if the type is unconstrained or
- class-wide.
+ /* See if this is a renaming, and handle appropriately depending on
+ what is renamed and in which context. There are three major
+ cases:
- Otherwise, if what we are renaming is a reference, we can simply
- return a stabilized version of that reference, after forcing any
- SAVE_EXPRs to be evaluated. But, if this is at global level, we
- can only do this if we know no SAVE_EXPRs will be made.
+ 1/ This is a constant renaming and we can just make an object
+ with what is renamed as its initial value,
- Otherwise, make this into a constant pointer to the object we are
- to rename. */
+ 2/ We can reuse a stabilized version of what is renamed in place
+ of the renaming,
+ 3/ If neither 1 or 2 applies, we make the renaming entity a constant
+ pointer to what is being renamed. */
+
if (Present (Renamed_Object (gnat_entity)))
{
/* If the renamed object had padding, strip off the reference
@@ -756,6 +750,9 @@
gnu_type = TREE_TYPE (gnu_expr);
}
+ /* Case 1: If this is a constant renaming, treat it as a normal
+ object whose initial value is what is being renamed. We cannot
+ do this if the type is unconstrained or class-wide. */
if (const_flag
&& !TREE_SIDE_EFFECTS (gnu_expr)
&& TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
@@ -764,49 +761,100 @@
&& !Is_Array_Type (Etype (gnat_entity)))
;
- /* If this is a declaration or reference that we can stabilize,
- just use that declaration or reference as this entity unless
- the latter has to be materialized. */
- else if ((DECL_P (gnu_expr) || REFERENCE_CLASS_P (gnu_expr))
- && !Materialize_Entity (gnat_entity)
- && (!global_bindings_p ()
- || (staticp (gnu_expr)
- && !TREE_SIDE_EFFECTS (gnu_expr))))
- {
- gnu_decl = gnat_stabilize_reference (gnu_expr, true);
- save_gnu_tree (gnat_entity, gnu_decl, true);
- saved = true;
- break;
- }
-
- /* Otherwise, make this into a constant pointer to the object we
- are to rename and attach the object to the pointer. We need
- to stabilize too since the renaming evaluation may directly
- reference the renamed object instead of the pointer we will
- attach it to. We don't want variables in the expression to
- be evaluated every time the renaming is used, since their
- value may change in between. */
+ /* Otherwise, see if we can proceed with a stabilized version of
+ the renamed entity or if we need to make a pointer. */
else
{
- bool has_side_effects = TREE_SIDE_EFFECTS (gnu_expr);
- inner_const_flag = TREE_READONLY (gnu_expr);
- const_flag = true;
- gnu_type = build_reference_type (gnu_type);
- renamed_obj = gnat_stabilize_reference (gnu_expr, true);
- gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, renamed_obj);
+ bool stabilized;
+ tree maybe_stable_expr = NULL_TREE;
- if (!global_bindings_p ())
+ /* Case 2: If the renaming entity need not be materialized and
+ the renamed expression is something we can stabilize, use
+ that for the renaming after forcing the evaluation of any
+ SAVE_EXPR. At the global level, we can only do this if we
+ know no SAVE_EXPRs will be made. */
+ if (!Materialize_Entity (gnat_entity)
+ && (!global_bindings_p ()
+ || (staticp (gnu_expr)
+ && !TREE_SIDE_EFFECTS (gnu_expr))))
{
- /* If the original expression had side effects, put a
- SAVE_EXPR around this whole thing. */
- if (has_side_effects)
- gnu_expr = save_expr (gnu_expr);
+ maybe_stable_expr
+ = maybe_stabilize_reference (gnu_expr, true, false,
+ &stabilized);
- add_stmt (gnu_expr);
+ if (stabilized)
+ {
+ gnu_decl = maybe_stable_expr;
+ save_gnu_tree (gnat_entity, gnu_decl, true);
+ saved = true;
+ break;
+ }
+
+ /* The stabilization failed. Keep maybe_stable_expr
+ untouched here to let the pointer case below know
+ about that failure. */
}
- gnu_size = NULL_TREE;
- used_by_ref = true;
+ /* Case 3: Make this into a constant pointer to the object we
+ are to rename and attach the object to the pointer if it is
+ an lvalue that can be stabilized.
+
+ From the proper scope, attached objects will be referenced
+ directly instead of indirectly via the pointer to avoid
+ subtle aliasing problems with non addressable entities.
+ They have to be stable because we must not evaluate the
+ variables in the expression every time the renaming is used.
+ They also have to be lvalues because the context in which
+ they are reused sometimes requires so. We call pointers
+ with an attached object "renaming" pointers.
+
+ In the rare cases where we cannot stabilize the renamed
+ object, we just make a "bare" pointer, and the renamed
+ entity is always accessed indirectly through it. */
+ {
+ bool has_side_effects = TREE_SIDE_EFFECTS (gnu_expr);
+ inner_const_flag = TREE_READONLY (gnu_expr);
+ const_flag = true;
+ gnu_type = build_reference_type (gnu_type);
+
+ /* If a previous attempt at unrestricted
+ stabilization failed, there is no point trying
+ again and we can reuse the result without
+ attaching it to the pointer. */
+ if (maybe_stable_expr)
+ ;
+
+ /* Otherwise, try to stabilize now, restricting to
+ lvalues only, and attach the expression to the pointer
+ if the stabilization succeeds. */
+ else
+ {
+ maybe_stable_expr
+ = maybe_stabilize_reference (gnu_expr, true, true,
+ &stabilized);
+
+ if (stabilized)
+ renamed_obj = maybe_stable_expr;
+ /* Attaching is actually performed downstream, as soon
+ as we have a DECL for the pointer we make. */
+ }
+
+ gnu_expr
+ = build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr);
+
+ if (!global_bindings_p ())
+ {
+ /* If the original expression had side effects, put a
+ SAVE_EXPR around this whole thing. */
+ if (has_side_effects)
+ gnu_expr = save_expr (gnu_expr);
+
+ add_stmt (gnu_expr);
+ }
+
+ gnu_size = NULL_TREE;
+ used_by_ref = true;
+ }
}
}
@@ -894,10 +942,15 @@
imported. */
if ((!definition && Present (Address_Clause (gnat_entity)))
|| (Is_Imported (gnat_entity)
- && Convention (gnat_entity) == Convention_Stdcall))
+ && Has_Stdcall_Convention (gnat_entity)))
{
gnu_type = build_reference_type (gnu_type);
gnu_size = NULL_TREE;
+
+ gnu_expr = NULL_TREE;
+ /* No point in taking the address of an initializing expression
+ that isn't going to be used. */
+
used_by_ref = true;
}
@@ -1495,19 +1548,11 @@
TYPE_READONLY (gnu_template_type) = 1;
/* Make a node for the array. If we are not defining the array
- suppress expanding incomplete types and save the node as the type
- for GNAT_ENTITY. */
+ suppress expanding incomplete types. */
gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
+
if (!definition)
- {
- defer_incomplete_level++;
- this_deferred = this_made_decl = true;
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
- !Comes_From_Source (gnat_entity),
- debug_info_p, gnat_entity);
- save_gnu_tree (gnat_entity, gnu_decl, false);
- saved = true;
- }
+ defer_incomplete_level++, this_deferred = true;
/* Build the fat pointer type. Use a "void *" object instead of
a pointer to the array type since we don't have the array type
@@ -2310,9 +2355,9 @@
}
/* Make a node for the record. If we are not defining the record,
- suppress expanding incomplete types and save the node as the type
- for GNAT_ENTITY. We use the same RECORD_TYPE as for a dummy type
- and reset TYPE_DUMMY_P to show it's no longer a dummy.
+ suppress expanding incomplete types. We use the same RECORD_TYPE
+ as for a dummy type and reset TYPE_DUMMY_P to show it's no longer
+ a dummy.
It is very tempting to delay resetting this bit until we are done
with completing the type, e.g. to let possible intermediate
@@ -2335,15 +2380,7 @@
TYPE_PACKED (gnu_type) = packed || has_rep;
if (!definition)
- {
- defer_incomplete_level++;
- this_deferred = true;
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
- !Comes_From_Source (gnat_entity),
- debug_info_p, gnat_entity);
- save_gnu_tree (gnat_entity, gnu_decl, false);
- this_made_decl = saved = true;
- }
+ defer_incomplete_level++, this_deferred = true;
/* If both a size and rep clause was specified, put the size in
the record type now so that it can get the proper mode. */
@@ -3642,8 +3679,7 @@
if (list_length (gnu_return_list) == 1)
gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
-#ifdef TARGET_DLLIMPORT_DECL_ATTRIBUTES
- if (Convention (gnat_entity) == Convention_Stdcall)
+ if (Has_Stdcall_Convention (gnat_entity))
{
struct attrib *attr
= (struct attrib *) xmalloc (sizeof (struct attrib));
@@ -3655,7 +3691,6 @@
attr->error_point = gnat_entity;
attr_list = attr;
}
-#endif
/* Both lists ware built in reverse. */
gnu_param_list = nreverse (gnu_param_list);
@@ -3766,14 +3801,23 @@
compiling, then just get the type from its Etype. */
if (No (Full_View (gnat_entity)))
{
- /* If this is an incomplete type with no full view, it must
- be a Taft Amendement type, so just return a dummy type. */
+ /* If this is an incomplete type with no full view, it must be
+ either a limited view brought in by a limited_with clause, in
+ which case we use the non-limited view, or a Taft Amendement
+ type, in which case we just return a dummy type. */
if (kind == E_Incomplete_Type)
- gnu_type = make_dummy_type (gnat_entity);
+ {
+ if (From_With_Type (gnat_entity)
+ && Present (Non_Limited_View (gnat_entity)))
+ gnu_decl = gnat_to_gnu_entity (Non_Limited_View (gnat_entity),
+ NULL_TREE, 0);
+ else
+ gnu_type = make_dummy_type (gnat_entity);
+ }
- else if (Present (Underlying_Full_View (gnat_entity)))
- gnu_decl = gnat_to_gnu_entity (Underlying_Full_View (gnat_entity),
- NULL_TREE, 0);
+ else if (Present (Underlying_Full_View (gnat_entity)))
+ gnu_decl = gnat_to_gnu_entity (Underlying_Full_View (gnat_entity),
+ NULL_TREE, 0);
else
{
gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
@@ -4087,7 +4131,8 @@
DECL_ARTIFICIAL (gnu_decl) = 1;
if (!debug_info_p && DECL_P (gnu_decl)
- && TREE_CODE (gnu_decl) != FUNCTION_DECL)
+ && TREE_CODE (gnu_decl) != FUNCTION_DECL
+ && No (Renamed_Object (gnat_entity)))
DECL_IGNORED_P (gnu_decl) = 1;
/* If we haven't already, associate the ..._DECL node that we just made with
@@ -4703,9 +4748,9 @@
gnu_decl
= create_var_decl (create_concat_name (gnat_entity,
IDENTIFIER_POINTER (gnu_name)),
- NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, true,
- Is_Public (gnat_entity), !definition, false, NULL,
- gnat_entity);
+ NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
+ !need_debug, Is_Public (gnat_entity),
+ !definition, false, NULL, gnat_entity);
/* We only need to use this variable if we are in global context since GCC
can do the right thing in the local case. */
@@ -5812,6 +5857,7 @@
case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
+ case BIT_AND_EXPR: tcode = Bit_And_Expr; break;
case LT_EXPR: tcode = Lt_Expr; break;
case LE_EXPR: tcode = Le_Expr; break;
case GT_EXPR: tcode = Gt_Expr; break;
@@ -5898,8 +5944,7 @@
Set_Esize (gnat_field,
annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
}
- else if (type_annotate_only
- && Is_Tagged_Type (gnat_entity)
+ else if (Is_Tagged_Type (gnat_entity)
&& Is_Derived_Type (gnat_entity))
{
/* If there is no gnu_entry, this is an inherited component whose
@@ -6638,32 +6683,28 @@
tree
create_concat_name (Entity_Id gnat_entity, const char *suffix)
{
+ Entity_Kind kind = Ekind (gnat_entity);
+
const char *str = (!suffix ? "" : suffix);
String_Template temp = {1, strlen (str)};
Fat_Pointer fp = {str, &temp};
Get_External_Name_With_Suffix (gnat_entity, fp);
-#ifdef TARGET_DLLIMPORT_DECL_ATTRIBUTES
/* A variable using the Stdcall convention (meaning we are running
on a Windows box) live in a DLL. Here we adjust its name to use
the jump-table, the _imp__NAME contains the address for the NAME
variable. */
- {
- Entity_Kind kind = Ekind (gnat_entity);
- const char *prefix = "_imp__";
- int plen = strlen (prefix);
+ if ((kind == E_Variable || kind == E_Constant)
+ && Has_Stdcall_Convention (gnat_entity))
+ {
+ const char *prefix = "_imp__";
+ int k, plen = strlen (prefix);
- if ((kind == E_Variable || kind == E_Constant)
- && Convention (gnat_entity) == Convention_Stdcall)
- {
- int k;
- for (k = 0; k <= Name_Len; k++)
- Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
- strncpy (Name_Buffer, prefix, plen);
- }
- }
-#endif
+ for (k = 0; k <= Name_Len; k++)
+ Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
+ strncpy (Name_Buffer, prefix, plen);
+ }
return get_identifier (Name_Buffer);
}
Index: trans.c
===================================================================
--- trans.c (revision 106884)
+++ trans.c (working copy)
@@ -408,13 +408,7 @@
else if (TREE_CODE (gnu_result) == VAR_DECL
&& (renamed_obj = DECL_RENAMED_OBJECT (gnu_result)) != 0
&& (! DECL_RENAMING_GLOBAL_P (gnu_result)
- || global_bindings_p ())
- /* Make sure it's an lvalue like INDIRECT_REF. */
- && (DECL_P (renamed_obj)
- || REFERENCE_CLASS_P (renamed_obj)
- || (TREE_CODE (renamed_obj) == VIEW_CONVERT_EXPR
- && (DECL_P (TREE_OPERAND (renamed_obj, 0))
- || REFERENCE_CLASS_P (TREE_OPERAND (renamed_obj,0))))))
+ || global_bindings_p ()))
gnu_result = renamed_obj;
else
gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE,
@@ -719,6 +713,21 @@
= size_binop (MAX_EXPR, gnu_result,
DECL_SIZE (TREE_OPERAND (gnu_expr, 1)));
}
+ else if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
+ {
+ Node_Id gnat_deref = Prefix (gnat_node);
+ Node_Id gnat_actual_subtype = Actual_Designated_Subtype (gnat_deref);
+ tree gnu_ptr_type = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
+ if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
+ && Present (gnat_actual_subtype))
+ {
+ tree gnu_actual_obj_type = gnat_to_gnu_type (gnat_actual_subtype);
+ gnu_type = build_unc_object_type_from_ptr (gnu_ptr_type,
+ gnu_actual_obj_type, get_identifier ("SIZE"));
+ }
+
+ gnu_result = TYPE_SIZE (gnu_type);
+ }
else
gnu_result = TYPE_SIZE (gnu_type);
}
@@ -1564,8 +1573,15 @@
0, Etype (Name (gnat_node)), "PAD", false,
false, false);
- gnu_target = create_tmp_var_raw (gnu_obj_type, "LR");
- gnat_pushdecl (gnu_target, gnat_node);
+ /* ??? We may be about to create a static temporary if we happen to
+ be at the global binding level. That's a regression from what
+ the 3.x back-end would generate in the same situation, but we
+ don't have a mechanism in Gigi for creating automatic variables
+ in the elaboration routines. */
+ gnu_target
+ = create_var_decl (create_tmp_var_name ("LR"), NULL, gnu_obj_type,
+ NULL, false, false, false, false, NULL,
+ gnat_node);
}
gnu_actual_list
@@ -1602,6 +1618,7 @@
tree gnu_formal
= (present_gnu_tree (gnat_formal)
? get_gnu_tree (gnat_formal) : NULL_TREE);
+ tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
/* We treat a conversion between aggregate types as if it is an
unchecked conversion. */
bool unchecked_convert_p
@@ -1613,7 +1630,6 @@
tree gnu_name = gnat_to_gnu (gnat_name);
tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name));
tree gnu_actual;
- tree gnu_formal_type;
/* If it's possible we may need to use this expression twice, make sure
than any side-effects are handled via SAVE_EXPRs. Likewise if we need
@@ -1626,6 +1642,7 @@
if (Ekind (gnat_formal) != E_In_Parameter)
{
gnu_name = gnat_stabilize_reference (gnu_name, true);
+
if (!addressable_p (gnu_name)
&& gnu_formal
&& (DECL_BY_REF_P (gnu_formal)
@@ -1741,6 +1758,9 @@
gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
gnu_actual);
+ if (TREE_CODE (gnu_actual) != SAVE_EXPR)
+ gnu_actual = convert (gnu_formal_type, gnu_actual);
+
/* If we have not saved a GCC object for the formal, it means it is an
OUT parameter not passed by reference and that does not need to be
copied in. Otherwise, look at the PARM_DECL to see if it is passed by
@@ -1989,7 +2009,7 @@
&& TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
}
-
+
gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
gnu_actual, gnu_result);
annotate_with_node (gnu_result, gnat_actual);
@@ -2497,25 +2517,40 @@
return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
build_call_raise (CE_Range_Check_Failed));
- /* If this is a Statement and we are at top level, it must be part of
- the elaboration procedure, so mark us as being in that procedure
- and push our context. */
- if (!current_function_decl
- && ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
- && Nkind (gnat_node) != N_Null_Statement)
- || Nkind (gnat_node) == N_Procedure_Call_Statement
- || Nkind (gnat_node) == N_Label
- || Nkind (gnat_node) == N_Implicit_Label_Declaration
- || Nkind (gnat_node) == N_Handled_Sequence_Of_Statements
- || ((Nkind (gnat_node) == N_Raise_Constraint_Error
- || Nkind (gnat_node) == N_Raise_Storage_Error
- || Nkind (gnat_node) == N_Raise_Program_Error)
- && (Ekind (Etype (gnat_node)) == E_Void))))
+ /* If this is a Statement and we are at top level, it must be part of the
+ elaboration procedure, so mark us as being in that procedure and push our
+ context.
+
+ If we are in the elaboration procedure, check if we are violating a a
+ No_Elaboration_Code restriction by having a statement there. */
+ if ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call)
+ && Nkind (gnat_node) != N_Null_Statement)
+ || Nkind (gnat_node) == N_Procedure_Call_Statement
+ || Nkind (gnat_node) == N_Label
+ || Nkind (gnat_node) == N_Implicit_Label_Declaration
+ || Nkind (gnat_node) == N_Handled_Sequence_Of_Statements
+ || ((Nkind (gnat_node) == N_Raise_Constraint_Error
+ || Nkind (gnat_node) == N_Raise_Storage_Error
+ || Nkind (gnat_node) == N_Raise_Program_Error)
+ && (Ekind (Etype (gnat_node)) == E_Void)))
{
- current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
- start_stmt_group ();
- gnat_pushlevel ();
- went_into_elab_proc = true;
+ if (!current_function_decl)
+ {
+ current_function_decl = TREE_VALUE (gnu_elab_proc_stack);
+ start_stmt_group ();
+ gnat_pushlevel ();
+ went_into_elab_proc = true;
+ }
+
+ /* Don't check for a possible No_Elaboration_Code restriction violation
+ on N_Handled_Sequence_Of_Statements, as we want to signal an error on
+ every nested real statement instead. This also avoids triggering
+ spurious errors on dummy (empty) sequences created by the front-end
+ for package bodies in some cases. */
+
+ if (current_function_decl == TREE_VALUE (gnu_elab_proc_stack)
+ && Nkind (gnat_node) != N_Handled_Sequence_Of_Statements)
+ Check_Elaboration_Code_Allowed (gnat_node);
}
switch (Nkind (gnat_node))
@@ -2982,7 +3017,7 @@
? Designated_Type (Etype
(Prefix (gnat_node)))
: Etype (Prefix (gnat_node))))
- gnu_prefix = gnat_stabilize_reference (gnu_prefix, 0);
+ gnu_prefix = gnat_stabilize_reference (gnu_prefix, false);
gnu_result
= build_component_ref (gnu_prefix, NULL_TREE, gnu_field,
@@ -3427,7 +3462,7 @@
/* If the type has a size that overflows, convert this into raise of
Storage_Error: execution shouldn't have gotten here anyway. */
if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
- && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
+ && TREE_OVERFLOW (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
gnu_result = build_call_raise (SE_Object_Too_Large);
else if (Nkind (Expression (gnat_node)) == N_Function_Call
&& !Do_Range_Check (Expression (gnat_node)))
@@ -3927,7 +3962,9 @@
if (!type_annotate_only)
{
tree gnu_ptr = gnat_to_gnu (Expression (gnat_node));
+ tree gnu_ptr_type = TREE_TYPE (gnu_ptr);
tree gnu_obj_type;
+ tree gnu_actual_obj_type = 0;
tree gnu_obj_size;
int align;
@@ -3952,7 +3989,21 @@
gnu_ptr);
gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
- gnu_obj_size = TYPE_SIZE_UNIT (gnu_obj_type);
+
+ if (Present (Actual_Designated_Subtype (gnat_node)))
+ {
+ gnu_actual_obj_type = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
+
+ if (TYPE_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
+ gnu_actual_obj_type
+ = build_unc_object_type_from_ptr (gnu_ptr_type,
+ gnu_actual_obj_type,
+ get_identifier ("DEALLOC"));
+ }
+ else
+ gnu_actual_obj_type = gnu_obj_type;
+
+ gnu_obj_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
align = TYPE_ALIGN (gnu_obj_type);
if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
@@ -4106,7 +4157,7 @@
if (TREE_SIDE_EFFECTS (gnu_result)
&& (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
|| CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
- gnu_result = gnat_stabilize_reference (gnu_result, 0);
+ gnu_result = gnat_stabilize_reference (gnu_result, false);
/* Now convert the result to the proper type. If the type is void or if
we have no result, return error_mark_node to show we have no result.
@@ -5709,17 +5760,26 @@
exp)));
}
-/* This is equivalent to stabilize_reference in GCC's tree.c, but we know
- how to handle our new nodes and we take an extra argument that says
- whether to force evaluation of everything. */
+/* This is equivalent to stabilize_reference in GCC's tree.c, but we know how
+ to handle our new nodes and we take extra arguments:
+ FORCE says whether to force evaluation of everything,
+
+ SUCCESS we set to true unless we walk through something we don't know how
+ to stabilize, or through something which is not an lvalue and LVALUES_ONLY
+ is true, in which cases we set to false. */
+
tree
-gnat_stabilize_reference (tree ref, bool force)
+maybe_stabilize_reference (tree ref, bool force, bool lvalues_only,
+ bool *success)
{
tree type = TREE_TYPE (ref);
enum tree_code code = TREE_CODE (ref);
tree result;
+ /* Assume we'll success unless proven otherwise. */
+ *success = true;
+
switch (code)
{
case VAR_DECL:
@@ -5728,6 +5788,15 @@
/* No action is needed in this case. */
return ref;
+ case ADDR_EXPR:
+ /* A standalone ADDR_EXPR is never an lvalue, and this one can't
+ be nested inside an outer INDIRECT_REF, since INDIREC_REF goes
+ straight to stabilize_1. */
+ if (lvalues_only)
+ goto failure;
+
+ /* ... Fallthru ... */
+
case NOP_EXPR:
case CONVERT_EXPR:
case FLOAT_EXPR:
@@ -5736,10 +5805,10 @@
case FIX_ROUND_EXPR:
case FIX_CEIL_EXPR:
case VIEW_CONVERT_EXPR:
- case ADDR_EXPR:
result
= build1 (code, type,
- gnat_stabilize_reference (TREE_OPERAND (ref, 0), force));
+ maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
+ lvalues_only, success));
break;
case INDIRECT_REF:
@@ -5750,15 +5819,16 @@
break;
case COMPONENT_REF:
- result = build3 (COMPONENT_REF, type,
- gnat_stabilize_reference (TREE_OPERAND (ref, 0),
- force),
- TREE_OPERAND (ref, 1), NULL_TREE);
+ result = build3 (COMPONENT_REF, type,
+ maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
+ lvalues_only, success),
+ TREE_OPERAND (ref, 1), NULL_TREE);
break;
case BIT_FIELD_REF:
result = build3 (BIT_FIELD_REF, type,
- gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
+ maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
+ lvalues_only, success),
gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
force),
gnat_stabilize_reference_1 (TREE_OPERAND (ref, 2),
@@ -5768,7 +5838,8 @@
case ARRAY_REF:
case ARRAY_RANGE_REF:
result = build4 (code, type,
- gnat_stabilize_reference (TREE_OPERAND (ref, 0), force),
+ maybe_stabilize_reference (TREE_OPERAND (ref, 0), force,
+ lvalues_only, success),
gnat_stabilize_reference_1 (TREE_OPERAND (ref, 1),
force),
NULL_TREE, NULL_TREE);
@@ -5778,17 +5849,21 @@
result = build2 (COMPOUND_EXPR, type,
gnat_stabilize_reference_1 (TREE_OPERAND (ref, 0),
force),
- gnat_stabilize_reference (TREE_OPERAND (ref, 1),
- force));
+ maybe_stabilize_reference (TREE_OPERAND (ref, 1), force,
+ lvalues_only, success));
break;
+ case ERROR_MARK:
+ ref = error_mark_node;
+
+ /* ... Fallthru to failure ... */
+
/* If arg isn't a kind of lvalue we recognize, make no change.
Caller should recognize the error for an invalid lvalue. */
default:
+ failure:
+ *success = false;
return ref;
-
- case ERROR_MARK:
- return error_mark_node;
}
TREE_READONLY (result) = TREE_READONLY (ref);
@@ -5808,6 +5883,17 @@
return result;
}
+/* Wrapper around maybe_stabilize_reference, for common uses without
+ lvalue restrictions and without need to examine the success
+ indication. */
+
+tree
+gnat_stabilize_reference (tree ref, bool force)
+{
+ bool stabilized;
+ return maybe_stabilize_reference (ref, force, false, &stabilized);
+}
+
/* Similar to stabilize_reference_1 in tree.c, but supports an extra
arg to force a SAVE_EXPR for everything. */
Index: gigi.h
===================================================================
--- gigi.h (revision 106884)
+++ gigi.h (working copy)
@@ -248,9 +248,21 @@
called. */
extern Node_Id error_gnat_node;
-/* This is equivalent to stabilize_reference in GCC's tree.c, but we know
- how to handle our new nodes and we take an extra argument that says
- whether to force evaluation of everything. */
+/* This is equivalent to stabilize_reference in GCC's tree.c, but we know how
+ to handle our new nodes and we take extra arguments.
+
+ FORCE says whether to force evaluation of everything,
+
+ SUCCESS we set to true unless we walk through something we don't
+ know how to stabilize, or through something which is not an lvalue
+ and LVALUES_ONLY is true, in which cases we set to false. */
+extern tree maybe_stabilize_reference (tree ref, bool force, bool lvalues_only,
+ bool *success);
+
+/* Wrapper around maybe_stabilize_reference, for common uses without
+ lvalue restrictions and without need to examine the success
+ indication. */
+
extern tree gnat_stabilize_reference (tree ref, bool force);
/* Highest number in the front-end node table. */
@@ -612,6 +624,11 @@
extern tree build_unc_object_type (tree template_type, tree object_type,
tree name);
+/* Same as build_unc_object_type, but taking a thin or fat pointer type
+ instead of the template type. */
+extern tree build_unc_object_type_from_ptr (tree thin_fat_ptr_type,
+ tree object_type, tree name);
+
/* 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. */
Index: utils2.c
===================================================================
--- utils2.c (revision 106884)
+++ utils2.c (working copy)
@@ -170,7 +170,7 @@
case NON_LVALUE_EXPR:
/* Conversions between pointers and integers don't change the alignment
of the underlying object. */
- this_alignment = known_alignment (TREE_OPERAND (exp, 0));
+ this_alignment = known_alignment (TREE_OPERAND (exp, 0));
break;
case PLUS_EXPR:
@@ -656,40 +656,6 @@
if (!operation_type)
operation_type = left_type;
- /* If the RHS has a conversion between record and array types and
- an inner type is no worse, use it. Note we cannot do this for
- modular types or types with TYPE_ALIGN_OK, since the latter
- might indicate a conversion between a root type and a class-wide
- type, which we must not remove. */
- while (TREE_CODE (right_operand) == VIEW_CONVERT_EXPR
- && (((TREE_CODE (right_type) == RECORD_TYPE
- || TREE_CODE (right_type) == UNION_TYPE)
- && !TYPE_JUSTIFIED_MODULAR_P (right_type)
- && !TYPE_ALIGN_OK (right_type)
- && !TYPE_IS_FAT_POINTER_P (right_type))
- || TREE_CODE (right_type) == ARRAY_TYPE)
- && ((((TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
- == RECORD_TYPE)
- || (TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
- == UNION_TYPE))
- && !(TYPE_JUSTIFIED_MODULAR_P
- (TREE_TYPE (TREE_OPERAND (right_operand, 0))))
- && !(TYPE_ALIGN_OK
- (TREE_TYPE (TREE_OPERAND (right_operand, 0))))
- && !(TYPE_IS_FAT_POINTER_P
- (TREE_TYPE (TREE_OPERAND (right_operand, 0)))))
- || (TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
- == ARRAY_TYPE))
- && (0 == (best_type
- = find_common_type (right_type,
- TREE_TYPE (TREE_OPERAND
- (right_operand, 0))))
- || right_type != best_type))
- {
- right_operand = TREE_OPERAND (right_operand, 0);
- right_type = TREE_TYPE (right_operand);
- }
-
/* If we are copying one array or record to another, find the best type
to use. */
if (((TREE_CODE (left_type) == ARRAY_TYPE
@@ -1159,12 +1125,18 @@
return build_unary_op (ADDR_EXPR, result_type,
TREE_OPERAND (operand, 0));
- /* If this NOP_EXPR doesn't change the mode, get the result type
- from this type and go down. We need to do this in case
- this is a conversion of a CONST_DECL. */
- if (TYPE_MODE (type) != BLKmode
- && (TYPE_MODE (type)
- == TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand, 0)))))
+ /* ... fallthru ... */
+
+ case VIEW_CONVERT_EXPR:
+ /* If this just a variant conversion or if the conversion doesn't
+ change the mode, get the result type from this type and go down.
+ This is needed for conversions of CONST_DECLs, to eventually get
+ to the address of their CORRESPONDING_VARs. */
+ if ((TYPE_MAIN_VARIANT (type)
+ == TYPE_MAIN_VARIANT (TREE_TYPE (TREE_OPERAND (operand, 0))))
+ || (TYPE_MODE (type) != BLKmode
+ && (TYPE_MODE (type)
+ == TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand, 0))))))
return build_unary_op (ADDR_EXPR,
(result_type ? result_type
: build_pointer_type (type)),
@@ -1409,7 +1381,7 @@
build_binary_op with the additional guarantee that the type
cannot involve a placeholder, since otherwise the function
would use the "target pointer" return mechanism. */
-
+
if (operation_type != TREE_TYPE (ret_val))
ret_val = convert (operation_type, ret_val);
@@ -1493,17 +1465,41 @@
build_int_cst (NULL_TREE, input_line));
}
+/* qsort comparer for the bit positions of two constructor elements
+ for record components. */
+
+static int
+compare_elmt_bitpos (const PTR rt1, const PTR rt2)
+{
+ tree elmt1 = * (tree *) rt1;
+ tree elmt2 = * (tree *) rt2;
+
+ 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;
+}
+
/* Return a CONSTRUCTOR of TYPE whose list is LIST. */
tree
gnat_build_constructor (tree type, tree list)
{
tree elmt;
+ int n_elmts;
bool allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST);
bool side_effects = false;
tree result;
- for (elmt = list; elmt; elmt = TREE_CHAIN (elmt))
+ /* Scan the elements to see if they are all constant or if any has side
+ effects, to let us set global flags on the resulting constructor. Count
+ the elements along the way for possible sorting purposes below. */
+ for (n_elmts = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), n_elmts ++)
{
if (!TREE_CONSTANT (TREE_VALUE (elmt))
|| (TREE_CODE (type) == RECORD_TYPE
@@ -1525,26 +1521,30 @@
return build1 (NULL_EXPR, type, TREE_OPERAND (result, 0));
}
- /* If TYPE is a RECORD_TYPE and the fields are not in the
- same order as their bit position, don't treat this as constant
- since varasm.c can't handle it. */
- if (allconstant && TREE_CODE (type) == RECORD_TYPE)
+ /* 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. */
+ if (allconstant && TREE_CODE (type) == RECORD_TYPE && n_elmts > 1)
{
- tree last_pos = bitsize_zero_node;
- tree field;
+ /* Fill an array with an element tree per index, and ask qsort to order
+ them according to what a bitpos comparison function says. */
- for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
- {
- tree this_pos = bit_position (field);
+ tree *gnu_arr = (tree *) alloca (sizeof (tree) * n_elmts);
+ int i;
- if (TREE_CODE (this_pos) != INTEGER_CST
- || tree_int_cst_lt (this_pos, last_pos))
- {
- allconstant = false;
- break;
- }
+ for (i = 0, elmt = list; elmt; elmt = TREE_CHAIN (elmt), i++)
+ gnu_arr[i] = elmt;
- last_pos = this_pos;
+ 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--)
+ {
+ TREE_CHAIN (gnu_arr[i]) = list;
+ list = gnu_arr[i];
}
}
@@ -1821,13 +1821,10 @@
fill in the parts that are known. */
else if (TYPE_FAT_OR_THIN_POINTER_P (result_type))
{
- tree template_type
- = (TYPE_FAT_POINTER_P (result_type)
- ? TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (result_type))))
- : TREE_TYPE (TYPE_FIELDS (TREE_TYPE (result_type))));
tree storage_type
- = build_unc_object_type (template_type, type,
- get_identifier ("ALLOC"));
+ = build_unc_object_type_from_ptr (result_type, type,
+ get_identifier ("ALLOC"));
+ tree template_type = TREE_TYPE (TYPE_FIELDS (storage_type));
tree storage_ptr_type = build_pointer_type (storage_type);
tree storage;
tree template_cons = NULL_TREE;
Index: utils.c
===================================================================
--- utils.c (revision 106884)
+++ utils.c (working copy)
@@ -324,8 +324,14 @@
if (global_bindings_p () && TREE_CODE (decl) != PARM_DECL)
DECL_CONTEXT (decl) = 0;
else
- DECL_CONTEXT (decl) = current_function_decl;
+ {
+ DECL_CONTEXT (decl) = current_function_decl;
+ /* Functions imported in another function are not really nested. */
+ if (TREE_CODE (decl) == FUNCTION_DECL && TREE_PUBLIC (decl))
+ DECL_NO_STATIC_CHAIN (decl) = 1;
+ }
+
TREE_NO_WARNING (decl) = (gnat_node == Empty || Warnings_Off (gnat_node));
/* Set the location of DECL and emit a declaration for it. */
@@ -1277,6 +1283,12 @@
|| (type_annotate_only && var_init && !TREE_CONSTANT (var_init)))
var_init = NULL_TREE;
+ /* At the global level, an initializer requiring code to be generated
+ produces elaboration statements. Check that such statements are allowed,
+ that is, not violating a No_Elaboration_Code restriction. */
+ if (global_bindings_p () && var_init != 0 && ! init_const)
+ Check_Elaboration_Code_Allowed (gnat_node);
+
/* Ada doesn't feature Fortran-like COMMON variables so we shouldn't
try to fiddle with DECL_COMMON. However, on platforms that don't
support global BSS sections, uninitialized global variables would
@@ -1313,6 +1325,10 @@
if (TREE_CODE (var_decl) != CONST_DECL)
rest_of_decl_compilation (var_decl, global_bindings_p (), 0);
+ else
+ /* expand CONST_DECLs to set their MODE, ALIGN, SIZE and SIZE_UNIT,
+ which we need for later back-annotations. */
+ expand_decl (var_decl);
return var_decl;
}
@@ -1607,7 +1623,7 @@
% DECL_ALIGN (curr_field) != 0);
/* If both the position and size of the previous field are multiples
- of the current field alignment, there can not be any gap. */
+ of the current field alignment, there cannot be any gap. */
if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field))
&& value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field)))
return false;
@@ -2444,6 +2460,22 @@
return type;
}
+
+/* Same, taking a thin or fat pointer type instead of a template type. */
+
+tree
+build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type, tree name)
+{
+ tree template_type;
+
+ gcc_assert (TYPE_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type));
+
+ template_type
+ = (TYPE_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);
+}
/* 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
@@ -2755,11 +2787,15 @@
expr)),
TYPE_MIN_VALUE (etype))));
- /* If the input is a justified modular type, we need to extract
- the actual object before converting it to any other type with the
- exception of an unconstrained array. */
+ /* If the input is a justified modular type, we need to extract the actual
+ object before converting it to any other type with the exceptions of an
+ unconstrained array or of a mere type variant. It is useful to avoid the
+ extraction and conversion in the type variant case because it could end
+ up replacing a VAR_DECL expr by a constructor and we might be about the
+ take the address of the result. */
if (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)
- && code != UNCONSTRAINED_ARRAY_TYPE)
+ && code != UNCONSTRAINED_ARRAY_TYPE
+ && TYPE_MAIN_VARIANT (type) != TYPE_MAIN_VARIANT (etype))
return convert (type, build_component_ref (expr, NULL_TREE,
TYPE_FIELDS (etype), false));
@@ -2804,9 +2840,7 @@
just make a new one in the proper type. */
if (code == ecode && AGGREGATE_TYPE_P (etype)
&& !(TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST
- && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
- && (TREE_CODE (expr) == STRING_CST
- || get_alias_set (etype) == get_alias_set (type)))
+ && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST))
{
expr = copy_node (expr);
TREE_TYPE (expr) = type;
@@ -2826,9 +2860,40 @@
break;
case VIEW_CONVERT_EXPR:
- if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)
- && !TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype))
- return convert (type, TREE_OPERAND (expr, 0));
+ {
+ /* GCC 4.x is very sensitive to type consistency overall, and view
+ conversions thus are very frequent. Eventhough just "convert"ing
+ the inner operand to the output type is fine in most cases, it
+ might expose unexpected input/output type mismatches in special
+ circumstances so we avoid such recursive calls when we can. */
+
+ tree op0 = TREE_OPERAND (expr, 0);
+
+ /* If we are converting back to the original type, we can just
+ lift the input conversion. This is a common occurence with
+ switches back-and-forth amongst type variants. */
+ if (type == TREE_TYPE (op0))
+ return op0;
+
+ /* Otherwise, if we're converting between two aggregate types, we
+ might be allowed to substitute the VIEW_CONVERT target type in
+ place or to just convert the inner expression. */
+ if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype))
+ {
+ /* If we are converting between type variants, we can just
+ substitute the VIEW_CONVERT in place. */
+ if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype))
+ return build1 (VIEW_CONVERT_EXPR, type, op0);
+
+ /* Otherwise, we may just bypass the input view conversion unless
+ one of the types is a fat pointer, or we're converting to an
+ unchecked union type. Both are handled by specialized code
+ below and the latter relies on exact type matching. */
+ else if (!TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype)
+ && !(code == UNION_TYPE && TYPE_UNCHECKED_UNION_P (type)))
+ return convert (type, op0);
+ }
+ }
break;
case INDIRECT_REF:
@@ -2957,13 +3022,10 @@
{
if (TREE_TYPE (tem) == etype)
return build1 (CONVERT_EXPR, type, expr);
-
- /* Accept slight type variations. */
- if (TREE_TYPE (tem) == TYPE_MAIN_VARIANT (etype)
- || (TREE_CODE (TREE_TYPE (tem)) == RECORD_TYPE
- && (TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (tem))
- || TYPE_IS_PADDING_P (TREE_TYPE (tem)))
- && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (tem))) == etype))
+ else if (TREE_CODE (TREE_TYPE (tem)) == RECORD_TYPE
+ && (TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (tem))
+ || TYPE_IS_PADDING_P (TREE_TYPE (tem)))
+ && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (tem))) == etype)
return build1 (CONVERT_EXPR, type,
convert (TREE_TYPE (tem), expr));
}
Index: utils.c
===================================================================
--- utils.c (revision 106884)
+++ utils.c (working copy)
@@ -324,8 +324,14 @@
if (global_bindings_p () && TREE_CODE (decl) != PARM_DECL)
DECL_CONTEXT (decl) = 0;
else
- DECL_CONTEXT (decl) = current_function_decl;
+ {
+ DECL_CONTEXT (decl) = current_function_decl;
+ /* Functions imported in another function are not really nested. */
+ if (TREE_CODE (decl) == FUNCTION_DECL && TREE_PUBLIC (decl))
+ DECL_NO_STATIC_CHAIN (decl) = 1;
+ }
+
TREE_NO_WARNING (decl) = (gnat_node == Empty || Warnings_Off (gnat_node));
/* Set the location of DECL and emit a declaration for it. */
@@ -1277,6 +1283,12 @@
|| (type_annotate_only && var_init && !TREE_CONSTANT (var_init)))
var_init = NULL_TREE;
+ /* At the global level, an initializer requiring code to be generated
+ produces elaboration statements. Check that such statements are allowed,
+ that is, not violating a No_Elaboration_Code restriction. */
+ if (global_bindings_p () && var_init != 0 && ! init_const)
+ Check_Elaboration_Code_Allowed (gnat_node);
+
/* Ada doesn't feature Fortran-like COMMON variables so we shouldn't
try to fiddle with DECL_COMMON. However, on platforms that don't
support global BSS sections, uninitialized global variables would
@@ -1313,6 +1325,10 @@
if (TREE_CODE (var_decl) != CONST_DECL)
rest_of_decl_compilation (var_decl, global_bindings_p (), 0);
+ else
+ /* expand CONST_DECLs to set their MODE, ALIGN, SIZE and SIZE_UNIT,
+ which we need for later back-annotations. */
+ expand_decl (var_decl);
return var_decl;
}
@@ -1607,7 +1623,7 @@
% DECL_ALIGN (curr_field) != 0);
/* If both the position and size of the previous field are multiples
- of the current field alignment, there can not be any gap. */
+ of the current field alignment, there cannot be any gap. */
if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field))
&& value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field)))
return false;
@@ -2444,6 +2460,22 @@
return type;
}
+
+/* Same, taking a thin or fat pointer type instead of a template type. */
+
+tree
+build_unc_object_type_from_ptr (tree thin_fat_ptr_type, tree object_type, tree name)
+{
+ tree template_type;
+
+ gcc_assert (TYPE_FAT_OR_THIN_POINTER_P (thin_fat_ptr_type));
+
+ template_type
+ = (TYPE_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);
+}
/* 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
@@ -2755,11 +2787,15 @@
expr)),
TYPE_MIN_VALUE (etype))));
- /* If the input is a justified modular type, we need to extract
- the actual object before converting it to any other type with the
- exception of an unconstrained array. */
+ /* If the input is a justified modular type, we need to extract the actual
+ object before converting it to any other type with the exceptions of an
+ unconstrained array or of a mere type variant. It is useful to avoid the
+ extraction and conversion in the type variant case because it could end
+ up replacing a VAR_DECL expr by a constructor and we might be about the
+ take the address of the result. */
if (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)
- && code != UNCONSTRAINED_ARRAY_TYPE)
+ && code != UNCONSTRAINED_ARRAY_TYPE
+ && TYPE_MAIN_VARIANT (type) != TYPE_MAIN_VARIANT (etype))
return convert (type, build_component_ref (expr, NULL_TREE,
TYPE_FIELDS (etype), false));
@@ -2804,9 +2840,7 @@
just make a new one in the proper type. */
if (code == ecode && AGGREGATE_TYPE_P (etype)
&& !(TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST
- && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
- && (TREE_CODE (expr) == STRING_CST
- || get_alias_set (etype) == get_alias_set (type)))
+ && TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST))
{
expr = copy_node (expr);
TREE_TYPE (expr) = type;
@@ -2826,9 +2860,40 @@
break;
case VIEW_CONVERT_EXPR:
- if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)
- && !TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype))
- return convert (type, TREE_OPERAND (expr, 0));
+ {
+ /* GCC 4.x is very sensitive to type consistency overall, and view
+ conversions thus are very frequent. Eventhough just "convert"ing
+ the inner operand to the output type is fine in most cases, it
+ might expose unexpected input/output type mismatches in special
+ circumstances so we avoid such recursive calls when we can. */
+
+ tree op0 = TREE_OPERAND (expr, 0);
+
+ /* If we are converting back to the original type, we can just
+ lift the input conversion. This is a common occurence with
+ switches back-and-forth amongst type variants. */
+ if (type == TREE_TYPE (op0))
+ return op0;
+
+ /* Otherwise, if we're converting between two aggregate types, we
+ might be allowed to substitute the VIEW_CONVERT target type in
+ place or to just convert the inner expression. */
+ if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype))
+ {
+ /* If we are converting between type variants, we can just
+ substitute the VIEW_CONVERT in place. */
+ if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype))
+ return build1 (VIEW_CONVERT_EXPR, type, op0);
+
+ /* Otherwise, we may just bypass the input view conversion unless
+ one of the types is a fat pointer, or we're converting to an
+ unchecked union type. Both are handled by specialized code
+ below and the latter relies on exact type matching. */
+ else if (!TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype)
+ && !(code == UNION_TYPE && TYPE_UNCHECKED_UNION_P (type)))
+ return convert (type, op0);
+ }
+ }
break;
case INDIRECT_REF:
@@ -2957,13 +3022,10 @@
{
if (TREE_TYPE (tem) == etype)
return build1 (CONVERT_EXPR, type, expr);
-
- /* Accept slight type variations. */
- if (TREE_TYPE (tem) == TYPE_MAIN_VARIANT (etype)
- || (TREE_CODE (TREE_TYPE (tem)) == RECORD_TYPE
- && (TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (tem))
- || TYPE_IS_PADDING_P (TREE_TYPE (tem)))
- && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (tem))) == etype))
+ else if (TREE_CODE (TREE_TYPE (tem)) == RECORD_TYPE
+ && (TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (tem))
+ || TYPE_IS_PADDING_P (TREE_TYPE (tem)))
+ && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (tem))) == etype)
return build1 (CONVERT_EXPR, type,
convert (TREE_TYPE (tem), expr));
}
Index: repinfo.h
===================================================================
--- repinfo.h (revision 106884)
+++ repinfo.h (working copy)
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1999-2002 Free Software Foundation, Inc. *
+ * Copyright (C) 1999-2005 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- *
@@ -67,6 +67,7 @@
#define Ge_Expr 25
#define Eq_Expr 26
#define Ne_Expr 27
+#define Bit_And_Expr 28
/* Creates a node using the tree code defined by Expr and from 1-3
operands as required (unused operands set as shown to No_Uint) Note
Index: repinfo.ads
===================================================================
--- repinfo.ads (revision 106884)
+++ repinfo.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2005, 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- --
@@ -35,7 +35,7 @@
-- tree to fill in representation information, and also the routine used
-- by -gnatR to print this information. This unit is used both in the
-- compiler and in ASIS (it is used in ASIS as part of the implementation
--- of the data decomposition annex.
+-- of the data decomposition annex).
with Types; use Types;
with Uintp; use Uintp;
@@ -128,7 +128,7 @@
-- Subtype used for values that can either be a Node_Ref (negative)
-- or a value (non-negative)
- type TCode is range 0 .. 27;
+ type TCode is range 0 .. 28;
-- Type used on Ada side to represent DEFTREECODE values defined in
-- tree.def. Only a subset of these tree codes can actually appear.
-- The names are the names from tree.def in Ada casing.
@@ -162,6 +162,7 @@
Ge_Expr : constant TCode := 25; -- comparision >= 2
Eq_Expr : constant TCode := 26; -- comparision = 2
Ne_Expr : constant TCode := 27; -- comparision /= 2
+ Bit_And_Expr : constant TCode := 28; -- Binary and 2
-- The following entry is used to represent a discriminant value in
-- the tree. It has a special tree code that does not correspond
Index: repinfo.adb
===================================================================
--- repinfo.adb (revision 106884)
+++ repinfo.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2005 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- --
@@ -48,6 +48,8 @@
with Uname; use Uname;
with Urealp; use Urealp;
+with Ada.Unchecked_Conversion;
+
package body Repinfo is
SSU : constant := 8;
@@ -61,17 +63,16 @@
-- Representation of gcc Expressions --
---------------------------------------
- -- This table is used only if Frontend_Layout_On_Target is False,
- -- so that gigi lays out dynamic size/offset fields using encoded
- -- gcc expressions.
+ -- This table is used only if Frontend_Layout_On_Target is False, so that
+ -- gigi lays out dynamic size/offset fields using encoded gcc
+ -- expressions.
- -- A table internal to this unit is used to hold the values of
- -- back annotated expressions. This table is written out by -gnatt
- -- and read back in for ASIS processing.
+ -- A table internal to this unit is used to hold the values of back
+ -- annotated expressions. This table is written out by -gnatt and read
+ -- back in for ASIS processing.
- -- Node values are stored as Uint values which are the negative of
- -- the node index in this table. Constants appear as non-negative
- -- Uint values.
+ -- Node values are stored as Uint values using the negative of the node
+ -- index in this table. Constants appear as non-negative Uint values.
type Exp_Node is record
Expr : TCode;
@@ -104,28 +105,27 @@
-- Identifier casing for current unit
Need_Blank_Line : Boolean;
- -- Set True if a blank line is needed before outputting any
- -- information for the current entity. Set True when a new
- -- entity is processed, and false when the blank line is output.
+ -- Set True if a blank line is needed before outputting any information for
+ -- the current entity. Set True when a new entity is processed, and false
+ -- when the blank line is output.
-----------------------
-- Local Subprograms --
-----------------------
function Back_End_Layout return Boolean;
- -- Test for layout mode, True = back end, False = front end. This
- -- function is used rather than checking the configuration parameter
- -- because we do not want Repinfo to depend on Targparm (for ASIS)
+ -- Test for layout mode, True = back end, False = front end. This function
+ -- is used rather than checking the configuration parameter because we do
+ -- not want Repinfo to depend on Targparm (for ASIS)
procedure Blank_Line;
-- Called before outputting anything for an entity. Ensures that
-- a blank line precedes the output for a particular entity.
procedure List_Entities (Ent : Entity_Id);
- -- This procedure lists the entities associated with the entity E,
- -- starting with the First_Entity and using the Next_Entity link.
- -- If a nested package is found, entities within the package are
- -- recursively processed.
+ -- This procedure lists the entities associated with the entity E, starting
+ -- with the First_Entity and using the Next_Entity link. If a nested
+ -- package is found, entities within the package are recursively processed.
procedure List_Name (Ent : Entity_Id);
-- List name of entity Ent in appropriate case. The name is listed with
@@ -135,8 +135,8 @@
-- List representation info for array type Ent
procedure List_Mechanisms (Ent : Entity_Id);
- -- List mechanism information for parameters of Ent, which is a
- -- subprogram, subprogram type, or an entry or entry family.
+ -- List mechanism information for parameters of Ent, which is subprogram,
+ -- subprogram type, or an entry or entry family.
procedure List_Object_Info (Ent : Entity_Id);
-- List representation info for object Ent
@@ -155,12 +155,11 @@
-- Output given number of spaces
procedure Write_Info_Line (S : String);
- -- Routine to write a line to Repinfo output file. This routine is
- -- passed as a special output procedure to Output.Set_Special_Output.
- -- Note that Write_Info_Line is called with an EOL character at the
- -- end of each line, as per the Output spec, but the internal call
- -- to the appropriate routine in Osint requires that the end of line
- -- sequence be stripped off.
+ -- Routine to write a line to Repinfo output file. This routine is passed
+ -- as a special output procedure to Output.Set_Special_Output. Note that
+ -- Write_Info_Line is called with an EOL character at the end of each line,
+ -- as per the Output spec, but the internal call to the appropriate routine
+ -- in Osint requires that the end of line sequence be stripped off.
procedure Write_Mechanism (M : Mechanism_Type);
-- Writes symbolic string for mechanism represented by M
@@ -168,8 +167,8 @@
procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False);
-- Given a representation value, write it out. No_Uint values or values
-- dependent on discriminants are written as two question marks. If the
- -- flag Paren is set, then the output is surrounded in parentheses if
- -- it is other than a simple value.
+ -- flag Paren is set, then the output is surrounded in parentheses if it is
+ -- other than a simple value.
---------------------
-- Back_End_Layout --
@@ -177,8 +176,8 @@
function Back_End_Layout return Boolean is
begin
- -- We have back end layout if the back end has made any entries in
- -- the table of GCC expressions, otherwise we have front end layout.
+ -- We have back end layout if the back end has made any entries in the
+ -- table of GCC expressions, otherwise we have front end layout.
return Rep_Table.Last > 0;
end Back_End_Layout;
@@ -350,10 +349,10 @@
while Present (E) loop
Need_Blank_Line := True;
- -- We list entities that come from source (excluding private
- -- or incomplete types or deferred constants, where we will
- -- list the info for the full view). If debug flag A is set,
- -- then all entities are listed
+ -- We list entities that come from source (excluding private or
+ -- incomplete types or deferred constants, where we will list the
+ -- info for the full view). If debug flag A is set, then all
+ -- entities are listed
if (Comes_From_Source (E)
and then not Is_Incomplete_Or_Private_Type (E)
@@ -402,10 +401,9 @@
end if;
- -- Recurse into nested package, but not if they are
- -- package renamings (in particular renamings of the
- -- enclosing package, as for some Java bindings and
- -- for generic instances).
+ -- Recurse into nested package, but not if they are package
+ -- renamings (in particular renamings of the enclosing package,
+ -- as for some Java bindings and for generic instances).
if Ekind (E) = E_Package then
if No (Renamed_Object (E)) then
@@ -438,10 +436,10 @@
E := Next_Entity (E);
end loop;
- -- For a package body, the entities of the visible subprograms
- -- are declared in the corresponding spec. Iterate over its
- -- entities in order to handle properly the subprogram bodies.
- -- Skip bodies in subunits, which are listed independently.
+ -- For a package body, the entities of the visible subprograms are
+ -- declared in the corresponding spec. Iterate over its entities in
+ -- order to handle properly the subprogram bodies. Skip bodies in
+ -- subunits, which are listed independently.
if Ekind (Ent) = E_Package_Body
and then Present (Corresponding_Spec (Find_Declaration (Ent)))
@@ -583,6 +581,9 @@
Write_Str ("not ");
Print_Expr (Node.Op1);
+ when Bit_And_Expr =>
+ Binop (" & ");
+
when Lt_Expr =>
Binop (" < ");
@@ -801,9 +802,9 @@
UI_Image (Sunit);
end if;
- -- If the record is not packed, then we know that all
- -- fields whose position is not specified have a starting
- -- normalized bit position of zero
+ -- If the record is not packed, then we know that all fields whose
+ -- position is not specified have a starting normalized bit
+ -- position of zero
if Unknown_Normalized_First_Bit (Comp)
and then not Is_Packed (Ent)
@@ -885,11 +886,11 @@
UI_Write (Fbit);
Write_Str (" .. ");
- -- Allowing Uint_0 here is a kludge, really this should be
- -- a fine Esize value but currently it means unknown, except
- -- that we know after gigi has back annotated that a size of
- -- zero is real, since otherwise gigi back annotates using
- -- No_Uint as the value to indicate unknown).
+ -- Allowing Uint_0 here is a kludge, really this should be a
+ -- fine Esize value but currently it means unknown, except that
+ -- we know after gigi has back annotated that a size of zero is
+ -- real, since otherwise gigi back annotates using No_Uint as
+ -- the value to indicate unknown).
if (Esize (Comp) = Uint_0 or else Known_Static_Esize (Comp))
and then Known_Static_Normalized_First_Bit (Comp)
@@ -916,8 +917,8 @@
Write_Val (Esiz, Paren => True);
- -- If in front end layout mode, then dynamic size is
- -- stored in storage units, so renormalize for output
+ -- If in front end layout mode, then dynamic size is stored
+ -- in storage units, so renormalize for output
if not Back_End_Layout then
Write_Str (" * ");
@@ -1019,8 +1020,8 @@
Write_Line (";");
-- For now, temporary case, to be removed when gigi properly back
- -- annotates RM_Size, if RM_Size is not set, then list Esize as
- -- Size. This avoids odd Object_Size output till we fix things???
+ -- annotates RM_Size, if RM_Size is not set, then list Esize as Size.
+ -- This avoids odd Object_Size output till we fix things???
elsif Unknown_RM_Size (Ent) then
Write_Str ("for ");
@@ -1086,6 +1087,14 @@
function V (Val : Node_Ref_Or_Val) return Uint;
-- Internal recursive routine to evaluate tree
+ function W (Val : Uint) return Word;
+ -- Convert Val to Word, assuming Val is always in the Int range. This is
+ -- a helper function for the evaluation of bitwise expressions like
+ -- Bit_And_Expr, for which there is no direct support in uintp. Uint
+ -- values out of the Int range are expected to be seen in such
+ -- expressions only with overflowing byte sizes around, introducing
+ -- inherent unreliabilties in computations anyway.
+
-------
-- B --
-------
@@ -1113,6 +1122,23 @@
end T;
-------
+ -- W --
+ -------
+
+ -- We use an unchecked conversion to map Int values to their Word
+ -- bitwise equivalent, which we could not achieve with a normal type
+ -- conversion for negative Ints. We want bitwise equivalents because W
+ -- is used as a helper for bit operators like Bit_And_Expr, and can be
+ -- called for negative Ints in the context of aligning expressions like
+ -- X+Align & -Align.
+
+ function W (Val : Uint) return Word is
+ function To_Word is new Ada.Unchecked_Conversion (Int, Word);
+ begin
+ return To_Word (UI_To_Int (Val));
+ end W;
+
+ -------
-- V --
-------
@@ -1203,6 +1229,11 @@
when Truth_Not_Expr =>
return B (not T (Node.Op1));
+ when Bit_And_Expr =>
+ L := V (Node.Op1);
+ R := V (Node.Op2);
+ return UI_From_Int (Int (W (L) and W (R)));
+
when Lt_Expr =>
return B (V (Node.Op1) < V (Node.Op2));
More information about the Gcc-patches
mailing list