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 <schonb...@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.
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 238104)
+++ sem_prag.adb (working copy)
@@ -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
Index: sem_prag.ads
===================================================================
--- sem_prag.ads (revision 238104)
+++ sem_prag.ads (working copy)
@@ -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
Index: freeze.adb
===================================================================
--- freeze.adb (revision 238109)
+++ freeze.adb (working copy)
@@ -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;
