Skip to content

R
riscv-gcc-1
Commit 0f4cb75c by Arnaud Charlet
Options

Temporarily undo previous change, which seems to be causing random 

failures.

From-SVN: r128372
parent 97695e47
Showing with 51 additions and 94 deletions
gcc/ada/ChangeLog
2007-09-11 Javier Miranda <miranda@adacore.com>
* einfo.ads, einfo.adb (Dispatch_Table_Wrapper): New attribute. Present
in library level record type entities if we are generating statically
allocated dispatch tables.
* exp_disp.adb (Make_Tags/Make_DT): Replace previous code
importing/exporting the _tag declaration by new code
importing/exporting the dispatch table wrapper. This change allows us
to statically allocate of the TSD.
(Make_DT.Export_DT): New procedure.
(Build_Static_DT): New function.
(Has_DT): New function.
* freeze.adb (Freeze_Static_Object): Code cleanup: Do not reset flags
True_Constant and Current_Value. Required to statically
allocate the dispatch tables.
(Check_Allocator): Make function iterative instead of recursive.
Also return inner allocator node, when present, so that we do not have
to look for that node again in the caller.
2007-09-11 Jan Hubicka <jh@suse.cz>
* misc.c (gnat_expand_body): Kill.
gcc/ada/einfo.adb
......@@ -217,7 +217,6 @@ package body Einfo is
-- DT_Offset_To_Top_Func Node25
-- Task_Body_Procedure Node25
-- Dispatch_Table_Wrapper Node16
-- Overridden_Operation Node26
-- Package_Instantiation Node26
-- Related_Interface Node26
......@@ -843,12 +842,6 @@ package body Einfo is
return Uint15 (Id);
end Discriminant_Number;
function Dispatch_Table_Wrapper (Id : E) return E is
begin
pragma Assert (Is_Tagged_Type (Id));
return Node26 (Implementation_Base_Type (Id));
end Dispatch_Table_Wrapper;
function DT_Entry_Count (Id : E) return U is
begin
pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id));
......@@ -3123,12 +3116,6 @@ package body Einfo is
Set_Uint15 (Id, V);
end Set_Discriminant_Number;
procedure Set_Dispatch_Table_Wrapper (Id : E; V : E) is
begin
pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id));
Set_Node26 (Id, V);
end Set_Dispatch_Table_Wrapper;
procedure Set_DT_Entry_Count (Id : E; V : U) is
begin
pragma Assert (Ekind (Id) = E_Component);
......@@ -8266,10 +8253,6 @@ package body Einfo is
Write_Str ("Static_Initialization");
end if;
when E_Record_Type |
E_Record_Type_With_Private =>
Write_Str ("Dispatch_Table_Wrapper");
when others =>
Write_Str ("Field26??");
end case;
......
gcc/ada/einfo.ads
......@@ -819,12 +819,6 @@ package Einfo is
-- the list of discriminants of the type, i.e. a sequential integer
-- index starting at 1 and ranging up to Number_Discriminants.
-- Dispatch_Table_Wrapper (Node26) [implementation base type only]
-- Present in library level record type entities if we are generating
-- statically allocated dispatch tables. For a tagged type, points to
-- the dispatch table wrapper associated with the tagged type. For a
-- non-tagged record, contains Empty.
-- DTC_Entity (Node16)
-- Present in function and procedure entities. Set to Empty unless
-- the subprogram is dispatching in which case it references the
......@@ -5126,7 +5120,6 @@ package Einfo is
-- E_Record_Subtype
-- Primitive_Operations (Elist15)
-- Access_Disp_Table (Elist16) (base type only)
-- Dispatch_Table_Wrapper (Node26) (base type only)
-- Cloned_Subtype (Node16) (subtype case only)
-- First_Entity (Node17)
-- Corresponding_Concurrent_Type (Node18)
......@@ -5160,7 +5153,6 @@ package Einfo is
-- E_Record_Subtype_With_Private
-- Primitive_Operations (Elist15)
-- Access_Disp_Table (Elist16) (base type only)
-- Dispatch_Table_Wrapper (Node26) (base type only)
-- First_Entity (Node17)
-- Private_Dependents (Elist18)
-- Underlying_Full_View (Node19)
......@@ -5555,7 +5547,6 @@ package Einfo is
function Current_Value (Id : E) return N;
function Debug_Info_Off (Id : E) return B;
function Debug_Renaming_Link (Id : E) return E;
function Dispatch_Table_Wrapper (Id : E) return E;
function DTC_Entity (Id : E) return E;
function DT_Entry_Count (Id : E) return U;
function DT_Offset_To_Top_Func (Id : E) return E;
......@@ -6057,7 +6048,6 @@ package Einfo is
procedure Set_Abstract_Interfaces (Id : E; V : L);
procedure Set_Accept_Address (Id : E; V : L);
procedure Set_Access_Disp_Table (Id : E; V : L);
procedure Set_Dispatch_Table_Wrapper (Id : E; V : E);
procedure Set_Actual_Subtype (Id : E; V : E);
procedure Set_Address_Taken (Id : E; V : B := True);
procedure Set_Alias (Id : E; V : E);
......@@ -6686,7 +6676,6 @@ package Einfo is
pragma Inline (Current_Value);
pragma Inline (Debug_Info_Off);
pragma Inline (Debug_Renaming_Link);
pragma Inline (Dispatch_Table_Wrapper);
pragma Inline (DTC_Entity);
pragma Inline (DT_Entry_Count);
pragma Inline (DT_Offset_To_Top_Func);
......@@ -7091,7 +7080,6 @@ package Einfo is
pragma Inline (Set_Current_Value);
pragma Inline (Set_Debug_Info_Off);
pragma Inline (Set_Debug_Renaming_Link);
pragma Inline (Set_Dispatch_Table_Wrapper);
pragma Inline (Set_DTC_Entity);
pragma Inline (Set_DT_Entry_Count);
pragma Inline (Set_DT_Offset_To_Top_Func);
......
gcc/ada/freeze.adb
......@@ -1461,10 +1461,9 @@ package body Freeze is
-- Set True if we find at least one component with a component
-- clause (used to warn about useless Bit_Order pragmas).
function Check_Allocator (N : Node_Id) return Node_Id;
-- If N is an allocator, possibly wrapped in one or more level of
-- qualified expression(s), return the inner allocator node, else
-- return Empty.
function Check_Allocator (N : Node_Id) return Boolean;
-- Returns True if N is an expression or a qualified expression with
-- an allocator.
procedure Check_Itype (Typ : Entity_Id);
-- If the component subtype is an access to a constrained subtype of
......@@ -1480,22 +1479,15 @@ package body Freeze is
-- Check_Allocator --
---------------------
function Check_Allocator (N : Node_Id) return Node_Id is
Inner : Node_Id;
function Check_Allocator (N : Node_Id) return Boolean is
begin
Inner := N;
loop
if Nkind (Inner) = N_Allocator then
return Inner;
elsif Nkind (Inner) = N_Qualified_Expression then
Inner := Expression (Inner);
else
return Empty;
end if;
end loop;
if Nkind (N) = N_Allocator then
return True;
elsif Nkind (N) = N_Qualified_Expression then
return Check_Allocator (Expression (N));
else
return False;
end if;
end Check_Allocator;
-----------------
......@@ -1846,40 +1838,43 @@ package body Freeze is
elsif Is_Access_Type (Etype (Comp))
and then Present (Parent (Comp))
and then Present (Expression (Parent (Comp)))
and then Check_Allocator (Expression (Parent (Comp)))
then
declare
Alloc : constant Node_Id :=
Check_Allocator (Expression (Parent (Comp)));
Alloc : Node_Id;
begin
if Present (Alloc) then
-- Handle qualified expressions
-- If component is pointer to a classwide type, freeze
-- the specific type in the expression being allocated.
-- The expression may be a subtype indication, in which
-- case freeze the subtype mark.
if Is_Class_Wide_Type
(Designated_Type (Etype (Comp)))
then
if Is_Entity_Name (Expression (Alloc)) then
Freeze_And_Append
(Entity (Expression (Alloc)), Loc, Result);
elsif
Nkind (Expression (Alloc)) = N_Subtype_Indication
then
Freeze_And_Append
(Entity (Subtype_Mark (Expression (Alloc))),
Loc, Result);
end if;
Alloc := Expression (Parent (Comp));
while Nkind (Alloc) /= N_Allocator loop
pragma Assert (Nkind (Alloc) = N_Qualified_Expression);
Alloc := Expression (Alloc);
end loop;
elsif Is_Itype (Designated_Type (Etype (Comp))) then
Check_Itype (Etype (Comp));
-- If component is pointer to a classwide type, freeze the
-- specific type in the expression being allocated. The
-- expression may be a subtype indication, in which case
-- freeze the subtype mark.
else
if Is_Class_Wide_Type (Designated_Type (Etype (Comp))) then
if Is_Entity_Name (Expression (Alloc)) then
Freeze_And_Append
(Designated_Type (Etype (Comp)), Loc, Result);
(Entity (Expression (Alloc)), Loc, Result);
elsif
Nkind (Expression (Alloc)) = N_Subtype_Indication
then
Freeze_And_Append
(Entity (Subtype_Mark (Expression (Alloc))),
Loc, Result);
end if;
elsif Is_Itype (Designated_Type (Etype (Comp))) then
Check_Itype (Etype (Comp));
else
Freeze_And_Append
(Designated_Type (Etype (Comp)), Loc, Result);
end if;
end;
......@@ -4702,6 +4697,18 @@ package body Freeze is
begin
Ensure_Type_Is_SA (Etype (E));
-- Reset True_Constant flag, since something strange is going on with
-- the scoping here, and our simple value tracing may not be sufficient
-- for this indication to be reliable. We kill the Constant_Value
-- and Last_Assignment indications for the same reason.
Set_Is_True_Constant (E, False);
Set_Current_Value (E, Empty);
if Ekind (E) = E_Variable then
Set_Last_Assignment (E, Empty);
end if;
exception
when Cannot_Be_Static =>
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment