summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/ada/lib-xref.adb30
-rw-r--r--gcc/ada/sem_ch7.adb73
-rw-r--r--gcc/ada/sem_disp.adb14
3 files changed, 106 insertions, 11 deletions
diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb
index 690cde9eb62..a7cc61a06e1 100644
--- a/gcc/ada/lib-xref.adb
+++ b/gcc/ada/lib-xref.adb
@@ -309,10 +309,6 @@ package body Lib.Xref is
return False;
end if;
end loop;
-
- -- Parent (N) is assignment statement, check whether N is its name
-
- return Name (Parent (N)) = N;
end Is_On_LHS;
---------------------------
@@ -1579,14 +1575,34 @@ package body Lib.Xref is
--------------------------
procedure Output_Overridden_Op (Old_E : Entity_Id) is
+ Op : Entity_Id;
+
begin
- if Present (Old_E)
- and then Sloc (Old_E) /= Standard_Location
+ -- The overridden operation has an implicit declaration
+ -- at the point of derivation. What we want to display
+ -- is the original operation, which has the actual body
+ -- (or abstract declaration) that is being overridden.
+ -- The overridden operation is not always set, e.g. when
+ -- it is a predefined operator.
+
+ if No (Old_E) then
+ return;
+
+ elsif Present (Alias (Old_E)) then
+ Op := Alias (Old_E);
+
+ else
+ Op := Old_E;
+ end if;
+
+ if Present (Op)
+ and then Sloc (Op) /= Standard_Location
then
declare
- Loc : constant Source_Ptr := Sloc (Old_E);
+ Loc : constant Source_Ptr := Sloc (Op);
Par_Unit : constant Unit_Number_Type :=
Get_Source_Unit (Loc);
+
begin
Write_Info_Char ('<');
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index 2e95a1f5f43..ebeec699183 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -51,6 +51,7 @@ with Sem_Ch8; use Sem_Ch8;
with Sem_Ch10; use Sem_Ch10;
with Sem_Ch12; use Sem_Ch12;
with Sem_Disp; use Sem_Disp;
+with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Snames; use Snames;
@@ -757,6 +758,12 @@ package body Sem_Ch7 is
-- private_with_clauses, and remove them at the end of the nested
-- package.
+ procedure Analyze_PPCs (Decls : List_Id);
+ -- Given a list of declarations, go through looking for subprogram
+ -- specs, and for each one found, analyze any pre/postconditions that
+ -- are chained to the spec. This is the implementation of the late
+ -- visibility analysis for preconditions and postconditions in specs.
+
procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id);
-- Clears constant indications (Never_Set_In_Source, Constant_Value,
-- and Is_True_Constant) on all variables that are entities of Id,
@@ -785,6 +792,33 @@ package body Sem_Ch7 is
-- private part rather than being done in Sem_Ch12.Install_Parent
-- (which is where the parents' visible declarations are installed).
+ ------------------
+ -- Analyze_PPCs --
+ ------------------
+
+ procedure Analyze_PPCs (Decls : List_Id) is
+ Decl : Node_Id;
+ Spec : Node_Id;
+ Sent : Entity_Id;
+ Prag : Node_Id;
+
+ begin
+ Decl := First (Decls);
+ while Present (Decl) loop
+ if Nkind (Original_Node (Decl)) = N_Subprogram_Declaration then
+ Spec := Specification (Original_Node (Decl));
+ Sent := Defining_Unit_Name (Spec);
+ Prag := Spec_PPC_List (Sent);
+ while Present (Prag) loop
+ Analyze_PPC_In_Decl_Part (Prag, Sent);
+ Prag := Next_Pragma (Prag);
+ end loop;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end Analyze_PPCs;
+
---------------------
-- Clear_Constants --
---------------------
@@ -937,9 +971,9 @@ package body Sem_Ch7 is
begin
Inst_Par := Inst_Id;
+
Gen_Par :=
Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
-
while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop
Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
@@ -1017,6 +1051,7 @@ package body Sem_Ch7 is
begin
if Present (Vis_Decls) then
Analyze_Declarations (Vis_Decls);
+ Analyze_PPCs (Vis_Decls);
end if;
-- Verify that incomplete types have received full declarations
@@ -1152,6 +1187,7 @@ package body Sem_Ch7 is
end if;
Analyze_Declarations (Priv_Decls);
+ Analyze_PPCs (Priv_Decls);
-- Check the private declarations for incomplete deferred constants
@@ -1345,13 +1381,17 @@ package body Sem_Ch7 is
Formal : Entity_Id;
begin
- if Etype (S) = T then
+ -- If the full view is a scalar type, the type is the anonymous
+ -- base type, but the operation mentions the first subtype, so
+ -- check the signature againt the base type.
+
+ if Base_Type (Etype (S)) = Base_Type (T) then
return True;
else
Formal := First_Formal (S);
while Present (Formal) loop
- if Etype (Formal) = T then
+ if Base_Type (Etype (Formal)) = Base_Type (T) then
return True;
end if;
@@ -1427,6 +1467,7 @@ package body Sem_Ch7 is
Replace_Elmt (Op_Elmt, New_Op);
Remove_Elmt (Op_List, Op_Elmt_2);
Set_Is_Overriding_Operation (New_Op);
+ Set_Overridden_Operation (New_Op, Parent_Subp);
-- We don't need to inherit its dispatching slot.
-- Set_All_DT_Position has previously ensured that
@@ -1664,11 +1705,18 @@ package body Sem_Ch7 is
-- when the parent type is defined in the parent unit. At this
-- point the current type is not private either, and we have to
-- install the underlying full view, which is now visible.
+ -- Save the current full view as well, so that all views can
+ -- be restored on exit. It may seem that after compiling the
+ -- child body there are not environments to restore, but the
+ -- back-end expects those links to be valid, and freeze nodes
+ -- depend on them.
if No (Full_View (Full))
and then Present (Underlying_Full_View (Full))
then
Set_Full_View (Id, Underlying_Full_View (Full));
+ Set_Underlying_Full_View (Id, Full);
+
Set_Underlying_Full_View (Full, Empty);
Set_Is_Frozen (Full_View (Id));
end if;
@@ -2153,7 +2201,8 @@ package body Sem_Ch7 is
end if;
-- Make private entities invisible and exchange full and private
- -- declarations for private types.
+ -- declarations for private types. Id is now the first private
+ -- entity in the package.
while Present (Id) loop
if Debug_Flag_E then
@@ -2240,6 +2289,22 @@ package body Sem_Ch7 is
Exchange_Declarations (Id);
+ -- If we have installed an underlying full view for a type
+ -- derived from a private type in a child unit, restore the
+ -- proper views of private and full view. See corresponding
+ -- code in Install_Private_Declarations.
+ -- After the exchange, Full denotes the private type in the
+ -- visible part of the package.
+
+ if Is_Private_Base_Type (Full)
+ and then Present (Full_View (Full))
+ and then Present (Underlying_Full_View (Full))
+ and then In_Package_Body (Current_Scope)
+ then
+ Set_Full_View (Full, Underlying_Full_View (Full));
+ Set_Underlying_Full_View (Full, Empty);
+ end if;
+
elsif Ekind (Id) = E_Incomplete_Type
and then No (Full_View (Id))
then
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 1652a82fc67..c990800ac56 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -31,6 +31,7 @@ with Exp_Disp; use Exp_Disp;
with Exp_Ch7; use Exp_Ch7;
with Exp_Tss; use Exp_Tss;
with Errout; use Errout;
+with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -790,6 +791,9 @@ package body Sem_Disp is
-- if the subprogram is already frozen, we must update
-- its dispatching information explicitly here. The
-- information is taken from the overridden subprogram.
+ -- We must also generate a cross-reference entry because
+ -- references to other primitives were already created
+ -- when type was frozen.
Body_Is_Last_Primitive := True;
@@ -819,6 +823,8 @@ package body Sem_Disp is
Prim => Subp,
Ins_Nod => Subp_Body);
end if;
+
+ Generate_Reference (Tagged_Type, Subp, 'p', False);
end if;
end if;
end if;
@@ -1543,6 +1549,14 @@ package body Sem_Disp is
if VM_Target = No_VM then
Expand_Dispatching_Call (Call_Node);
+
+ -- Expansion of a dispatching call results in an indirect call, which in
+ -- turn causes current values to be killed (see Resolve_Call), so on VM
+ -- targets we do the call here to ensure consistent warnings between VM
+ -- and non-VM targets.
+
+ else
+ Kill_Current_Values;
end if;
end Propagate_Tag;
View Lorry Controller Status