Skip to content

R
riscv-gcc-1
Commit 495d6dd6 by Robert Dewar Committed by Arnaud Charlet
Options

sem_ch7.adb (Check_Anonymous_Access_Types): Fix error for null body 

2007-04-20  Robert Dewar  <dewar@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* sem_ch7.adb (Check_Anonymous_Access_Types): Fix error for null body
	(Derive_Inherited_Private_Subprogram): Code cleanup. In case of explicit
	overriding of an inherited private subprogram now there is no need to
	inherit its dispatching slot and reduce the size of the dispatch table.
	Set_All_DT_Position now ensures that the same slot is now assigned to
	both entities. This is required to statically build the dispatch table.
	(Declare_Inherited_Private_Subprograms): Rewriten to avoid the need
	of calling Set_All_DT_Position to re-evaluate the position of the
	entries in the dispatch table. Such reevaluation is not desired if
	the tagged type is already frozen.

From-SVN: r125452
parent b7d1f17f
Showing with 61 additions and 48 deletions
gcc/ada/sem_ch7.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
......@@ -59,6 +59,7 @@ with Stand; use Stand;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Style;
with Uintp; use Uintp;
package body Sem_Ch7 is
......@@ -311,7 +312,7 @@ package body Sem_Ch7 is
Set_Has_Completion (Spec_Id);
Last_Spec_Entity := Last_Entity (Spec_Id);
New_Scope (Spec_Id);
Push_Scope (Spec_Id);
Set_Categorization_From_Pragmas (N);
......@@ -676,7 +677,7 @@ package body Sem_Ch7 is
Set_Ekind (Id, E_Package);
Set_Etype (Id, Standard_Void_Type);
New_Scope (Id);
Push_Scope (Id);
PF := Is_Pure (Enclosing_Lib_Unit_Entity);
Set_Is_Pure (Id, PF);
......@@ -1292,10 +1293,10 @@ package body Sem_Ch7 is
Set_Itype (IR, E);
if No (Declarations (P_Body)) then
Set_Declarations (P_Body, New_List);
Set_Declarations (P_Body, New_List (IR));
else
Prepend (IR, Declarations (P_Body));
end if;
Insert_Before (First (Declarations (P_Body)), IR);
end if;
Next_Entity (E);
......@@ -1307,15 +1308,6 @@ package body Sem_Ch7 is
-------------------------------------------
procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is
E : Entity_Id;
Op_List : Elist_Id;
Op_Elmt : Elmt_Id;
Op_Elmt_2 : Elmt_Id;
Prim_Op : Entity_Id;
New_Op : Entity_Id := Empty;
Parent_Subp : Entity_Id;
Found_Explicit : Boolean;
Decl_Privates : Boolean;
function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean;
-- Check whether an inherited subprogram is an operation of an
......@@ -1346,6 +1338,17 @@ package body Sem_Ch7 is
end if;
end Is_Primitive_Of;
-- Local variables
E : Entity_Id;
Op_List : Elist_Id;
Op_Elmt : Elmt_Id;
Op_Elmt_2 : Elmt_Id;
Prim_Op : Entity_Id;
New_Op : Entity_Id := Empty;
Parent_Subp : Entity_Id;
Tag : Entity_Id;
-- Start of processing for Declare_Inherited_Private_Subprograms
begin
......@@ -1367,17 +1370,14 @@ package body Sem_Ch7 is
if Is_Tagged_Type (E) then
Op_List := Primitive_Operations (E);
New_Op := Empty;
Decl_Privates := False;
Tag := First_Tag_Component (E);
Op_Elmt := First_Elmt (Op_List);
while Present (Op_Elmt) loop
Prim_Op := Node (Op_Elmt);
-- If the primitive operation is an implicit operation
-- with an internal name whose parent operation has
-- a normal name, then we now need to either declare the
-- operation (i.e., make it visible), or replace it
-- by an overriding operation if one exists.
-- Search primitives that are implicit operations with an
-- internal name whose parent operation has a normal name.
if Present (Alias (Prim_Op))
and then Find_Dispatching_Type (Alias (Prim_Op)) /= E
......@@ -1387,34 +1387,57 @@ package body Sem_Ch7 is
then
Parent_Subp := Alias (Prim_Op);
Found_Explicit := False;
-- Case 1: Check if the type has also an explicit
-- overriding for this primitive.
Op_Elmt_2 := Next_Elmt (Op_Elmt);
while Present (Op_Elmt_2) loop
if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
then
-- The private inherited operation has been
-- overridden by an explicit subprogram, so
-- change the private op's list element to
-- designate the explicit so the explicit
-- one will get the right dispatching slot.
-- overridden by an explicit subprogram: replace
-- the former by the latter.
New_Op := Node (Op_Elmt_2);
Replace_Elmt (Op_Elmt, New_Op);
Remove_Elmt (Op_List, Op_Elmt_2);
Found_Explicit := True;
Set_Is_Overriding_Operation (New_Op);
Decl_Privates := True;
exit;
-- We don't need to inherit its dispatching slot.
-- Set_All_DT_Position has previously ensured that
-- the same slot was assigned to the two primitives
if Present (Tag)
and then Present (DTC_Entity (New_Op))
and then Present (DTC_Entity (Prim_Op))
then
pragma Assert (DT_Position (New_Op)
= DT_Position (Prim_Op));
null;
end if;
goto Next_Primitive;
end if;
Next_Elmt (Op_Elmt_2);
end loop;
if not Found_Explicit then
Derive_Subprogram
(New_Op, Alias (Prim_Op), E, Etype (E));
-- Case 2: We have not found any explicit overriding and
-- hence we need to declare the operation (i.e., make it
-- visible).
Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E));
-- Inherit the dispatching slot if E is already frozen
if Is_Frozen (E)
and then Present (DTC_Entity (Alias (Prim_Op)))
then
Set_DTC_Entity_Value (E, New_Op);
Set_DT_Position (New_Op,
DT_Position (Alias (Prim_Op)));
end if;
pragma Assert
(Is_Dispatching_Operation (New_Op)
......@@ -1433,26 +1456,16 @@ package body Sem_Ch7 is
Replace_Elmt (Op_Elmt, New_Op);
Remove_Last_Elmt (Op_List);
Decl_Privates := True;
end if;
end if;
<<Next_Primitive>>
Next_Elmt (Op_Elmt);
end loop;
-- The type's DT attributes need to be recalculated
-- in the case where private dispatching operations
-- have been added or overridden. Normally this action
-- occurs during type freezing, but we force it here
-- since the type may already have been frozen (e.g.,
-- if the type's package has an empty private part).
-- This can only be done if expansion is active, otherwise
-- Tag may not be present.
if Decl_Privates
and then Expander_Active
then
Set_All_DT_Position (E);
-- Generate listing showing the contents of the dispatch table
if Debug_Flag_ZZ then
Write_DT (E);
end if;
else
......@@ -1825,7 +1838,7 @@ package body Sem_Ch7 is
Set_Stored_Constraint (Id, No_Elist);
if Present (Discriminant_Specifications (N)) then
New_Scope (Id);
Push_Scope (Id);
Process_Discriminants (N);
End_Scope;
......
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