===================================================================
@@ -26396,8 +26396,12 @@
procedure Build_Classwide_Expression
(Prag : Node_Id;
Subp : Entity_Id;
+ Par_Subp : Entity_Id;
Adjust_Sloc : Boolean)
is
+ Par_Formal : Entity_Id;
+ Subp_Formal : Entity_Id;
+
function Replace_Entity (N : Node_Id) return Traverse_Result;
-- Replace reference to formal of inherited operation or to primitive
-- operation of root type, with corresponding entity for derived type,
@@ -26503,6 +26507,17 @@
-- Start of processing for Build_Classwide_Expression
begin
+ -- Add mapping from old formals to new formals.
+
+ Par_Formal := First_Formal (Par_Subp);
+ Subp_Formal := First_Formal (Subp);
+
+ while Present (Par_Formal) and then Present (Subp_Formal) loop
+ Primitives_Mapping.Set (Par_Formal, Subp_Formal);
+ Next_Formal (Par_Formal);
+ Next_Formal (Subp_Formal);
+ end loop;
+
Replace_Condition_Entities (Prag);
end Build_Classwide_Expression;
@@ -26555,10 +26570,8 @@
Loc : constant Source_Ptr := Sloc (Prag);
Prag_Nam : constant Name_Id := Pragma_Name (Prag);
Check_Prag : Node_Id;
- Inher_Formal : Entity_Id;
Msg_Arg : Node_Id;
Nam : Name_Id;
- Subp_Formal : Entity_Id;
-- Start of processing for Build_Pragma_Check_Equivalent
@@ -26573,16 +26586,6 @@
Update_Primitives_Mapping (Inher_Id, Subp_Id);
- -- Add mapping from old formals to new formals.
-
- Inher_Formal := First_Formal (Inher_Id);
- Subp_Formal := First_Formal (Subp_Id);
- while Present (Inher_Formal) and then Present (Subp_Formal) loop
- Primitives_Mapping.Set (Inher_Formal, Subp_Formal);
- Next_Formal (Inher_Formal);
- Next_Formal (Subp_Formal);
- end loop;
-
-- Use generic machinery to copy inherited pragma, as if it were an
-- instantiation, resetting source locations appropriately, so that
-- expressions inside the inherited pragma use chained locations.
@@ -26592,10 +26595,14 @@
Set_Copied_Sloc_For_Inherited_Pragma
(Unit_Declaration_Node (Subp_Id), Inher_Id);
Check_Prag := New_Copy_Tree (Source => Prag);
- Build_Classwide_Expression (Check_Prag, Subp_Id, Adjust_Sloc => True);
- -- Otherwise simply copy the original pragma
+ -- Build the inherited classwide condition.
+ Build_Classwide_Expression
+ (Check_Prag, Subp_Id, Inher_Id, Adjust_Sloc => True);
+
+ -- If not an inherited condition simply copy the original pragma
+
else
Check_Prag := New_Copy_Tree (Source => Prag);
end if;
@@ -29301,7 +29308,8 @@
Subp_Id : Entity_Id)
is
function Overridden_Ancestor (S : Entity_Id) return Entity_Id;
- -- ??? what does this routine do?
+ -- Locate the primitive operation with the name of S whose controlling
+ -- type is the dispatching type of Inher_Id.
-------------------------
-- Overridden_Ancestor --
@@ -29333,7 +29341,7 @@
Old_Prim : Entity_Id;
Prim : Entity_Id;
- -- Start of processing for Primitive_Mapping
+ -- Start of processing for Update_Primitives_Mapping
begin
-- If the types are already in the map, it has been previously built for
===================================================================
@@ -247,10 +247,12 @@
procedure Build_Classwide_Expression
(Prag : Node_Id;
Subp : Entity_Id;
+ Par_Subp : Entity_Id;
Adjust_Sloc : Boolean);
-- Build the expression for an inherited classwide condition. Prag is
-- the pragma constructed from the corresponding aspect of the parent
- -- subprogram, and Subp is the overridding operation. Adjust_Sloc is True
+ -- subprogram, and Subp is the overridding operation and Par_Subp is
+ -- the overridden operation that has the condition. Adjust_Sloc is True
-- when the sloc of nodes traversed should be adjusted for the inherited
-- pragma. The routine is also called to check whether an inherited
-- operation that is not overridden but has inherited conditions need
===================================================================
@@ -23,51 +23,52 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Checks; use Checks;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Errout; use Errout;
-with Exp_Ch3; use Exp_Ch3;
-with Exp_Ch7; use Exp_Ch7;
-with Exp_Disp; use Exp_Disp;
-with Exp_Pakd; use Exp_Pakd;
-with Exp_Util; use Exp_Util;
-with Exp_Tss; use Exp_Tss;
-with Fname; use Fname;
-with Ghost; use Ghost;
-with Layout; use Layout;
-with Lib; use Lib;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Cat; use Sem_Cat;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Eval; use Sem_Eval;
-with Sem_Mech; use Sem_Mech;
-with Sem_Prag; use Sem_Prag;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
-with Warnsw; use Warnsw;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Checks; use Checks;
+with Contracts; use Contracts;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Errout; use Errout;
+with Exp_Ch3; use Exp_Ch3;
+with Exp_Ch7; use Exp_Ch7;
+with Exp_Disp; use Exp_Disp;
+with Exp_Pakd; use Exp_Pakd;
+with Exp_Util; use Exp_Util;
+with Exp_Tss; use Exp_Tss;
+with Fname; use Fname;
+with Ghost; use Ghost;
+with Layout; use Layout;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Eval; use Sem_Eval;
+with Sem_Mech; use Sem_Mech;
+with Sem_Prag; use Sem_Prag;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Stand; use Stand;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+with Warnsw; use Warnsw;
package body Freeze is
@@ -1417,6 +1418,16 @@
-- overriding operations.
if SPARK_Mode = On then
+
+ -- Analyze the contract items of the parent operation, before
+ -- they are rewritten when inherited.
+
+ Analyze_Entry_Or_Subprogram_Contract
+ (Overridden_Operation (Prim));
+
+ -- Now verify the legality of inherited contracts for LSP
+ -- conformance.
+
Collect_Inherited_Class_Wide_Conditions (Prim);
end if;
end if;
@@ -1440,15 +1451,15 @@
A_Pre := Find_Aspect (Par_Prim, Aspect_Pre);
if Present (A_Pre) and then Class_Present (A_Pre) then
- Build_Classwide_Expression (Expression (A_Pre), Prim,
- Adjust_Sloc => False);
+ Build_Classwide_Expression
+ (Expression (A_Pre), Prim, Par_Prim, Adjust_Sloc => False);
end if;
A_Post := Find_Aspect (Par_Prim, Aspect_Post);
if Present (A_Post) and then Class_Present (A_Post) then
- Build_Classwide_Expression (Expression (A_Post), Prim,
- Adjust_Sloc => False);
+ Build_Classwide_Expression
+ (Expression (A_Post), Prim, Par_Prim, Adjust_Sloc => False);
end if;
end if;
This patch fixes some spurious errors arising when class-wide preconditions in an generic instance are overridden in a child instance. The following must compile quietly: gcc -c r.ads --- generic package P is type T1 is abstract tagged private; procedure P1 (This : in out T1) with Pre'Class => T1'Class (This).F1 and then This.F2; function F1 (This : in T1) return Boolean is abstract; function F2 (This : in T1) return Boolean; private type T1 is abstract tagged record B : Boolean; end record; function F2 (This : in T1) return Boolean is (This.B); end P; --- package body P is procedure P1 (This : in out T1) is begin This.B := False; end P1; end P; --- generic package P.Q is type T2 is abstract new T1 with null record; overriding function F1 (This : in T2) return Boolean is (True); end P.Q; --- with P.Q; package R is package P_Instance is new P; package Q_Instance is new P_Instance.Q; type T3 is new Q_Instance.T2 with null record; end R; Tested on x86_64-pc-linux-gnu, committed on trunk 2016-07-07 Ed Schonberg <schonberg@adacore.com> * sem_prag.ads, sem_prag.adb (Build_Classwide_Expression): Include overridden operation as parameter, in order to map formals of the overridden and overring operation properly prior to rewriting the inherited condition. * freeze.adb (Check_Inherited_Cnonditions): Change call to Build_Class_Wide_Expression accordingly. In Spark_Mode, add call to analyze the contract of the parent operation, prior to mapping formals between operations.