[Ada] Support for discriminants in pragma Default_Initial_Condition
Arnaud Charlet
charlet@adacore.com
Tue Apr 25 08:52:00 GMT 2017
This patch adds support for tagged discriminants in assertion expressions such
as those of pragma Default_Initial_Condition or Type_Invariant'Class. In these
contexts, tagged discriminants behave as primitives and exhibit "overriding"-
like properties. For instance, if a derived type constrains its parent and
inherits a Default_Initial_Condition from it which checks the discriminant of
the parent, the runtime check must verify the discriminant of the derived type.
------------
-- Source --
------------
-- tester.ads
package Tester is
type Type_Id is
(No_Type,
Deriv_1_Id,
Deriv_2_Id,
Deriv_3_Id,
Deriv_4_Id,
Deriv_5_Id,
Deriv_6_Id,
Deriv_7_Id,
Deriv_8_Id,
Deriv_9_Id,
Deriv_10_Id,
Deriv_11_Id,
Deriv_12_Id,
Deriv_13_Id,
Deriv_14_Id,
Deriv_15_Id,
Deriv_16_Id,
Deriv_17_Id,
Deriv_18_Id,
Deriv_19_Id,
Deriv_20_Id,
Deriv_21_Id,
Deriv_22_Id,
Deriv_23_Id,
Deriv_24_Id,
Deriv_25_Id,
Deriv_26_Id,
Deriv_27_Id,
Deriv_28_Id,
Deriv_29_Id,
Deriv_30_Id,
Deriv_31_Id,
Deriv_32_Id,
Deriv_33_Id,
Deriv_34_Id,
Deriv_35_Id,
Deriv_36_Id,
Deriv_37_Id,
Deriv_38_Id,
Deriv_39_Id,
Deriv_40_Id,
Mid_13_Id,
Mid_14_Id,
Mid_19_Id,
Mid_33_Id,
Mid_34_Id,
Mid_39_Id,
Par_1_Id,
Par_2_Id,
Par_3_Id,
Par_4_Id,
Par_5_Id,
Par_6_Id,
Par_7_Id,
Par_8_Id,
Par_9_Id,
Par_10_Id,
Par_11_Id,
Par_12_Id,
Par_13_Id,
Par_14_Id,
Par_15_Id,
Par_16_Id,
Par_17_Id,
Par_18_Id,
Par_19_Id,
Par_20_Id);
type Result is record
X : Integer;
Y : Integer;
end record;
No_Result : constant Result := (0, 0);
type Results is array (Type_Id) of Result;
procedure Mark (Id : Type_Id; X : Integer; Y : Integer);
-- Record the result for a particular type
procedure Reset_Results;
-- Reset the internally kept result state
procedure Test_Result (Test_Id : String; Exp : Results);
-- Ensure that the internally kept result state agrees with expected
-- results Exp. Emit an error if this is not the case.
end Tester;
-- tester.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Tester is
State : Results;
----------
-- Mark --
----------
procedure Mark (Id : Type_Id; X : Integer; Y : Integer) is
begin
State (Id) := (X, Y);
end Mark;
-------------------
-- Reset_Results --
-------------------
procedure Reset_Results is
begin
State := (others => No_Result);
end Reset_Results;
-----------------
-- Test_Result --
-----------------
procedure Test_Result (Test_Id : String; Exp : Results) is
Exp_Val : Result;
Posted : Boolean := False;
State_Val : Result;
begin
for Index in Results'Range loop
Exp_Val := Exp (Index);
State_Val := State (Index);
if State_Val /= Exp_Val then
if not Posted then
Posted := True;
Put_Line (Test_Id & ": ERROR");
end if;
Put_Line
(" Index : " & Index'Img);
Put_Line
(" Expected:" & Exp_Val.X'Img & ',' & Exp_Val.Y'Img);
Put_Line
(" Got :" & State_Val.X'Img & ',' & State_Val.Y'Img);
end if;
end loop;
if not Posted then
Put_Line (Test_Id & ": OK");
end if;
end Test_Result;
end Tester;
-- dic_pack1.ads
package DIC_Pack1 is
-----------------------
-- 1) No derivations --
-----------------------
type No_Deriv_1 (D_1 : Integer; D_2 : Integer) is private
with Default_Initial_Condition => No_Deriv_1.D_1 > 1 and then D_2 > 2;
type No_Deriv_2 (D_1 : Integer; D_2 : Integer) is tagged private
with Default_Initial_Condition => No_Deriv_2.D_1 > 1 and then D_2 > 2;
---------------------------
-- 2) Tagged derivations --
---------------------------
-- No overriding
-- No discriminants
-- Visible derivation
type Par_1 (D_1 : Integer; D_2 : Integer) is tagged private
with Default_Initial_Condition => A (Par_1, Par_1.D_1, D_2);
function A (Obj : Par_1; X : Integer; Y : Integer) return Boolean;
type Deriv_1 is new Par_1 with private;
-- DIC calls: A (Par_1, Par_1.D_1, Par_1.D_2)
-- No overriding
-- Unknown discriminants
-- Hidden derivation
type Par_2 (D_1 : Integer; D_2 : Integer) is tagged private
with Default_Initial_Condition => B (Par_2, Par_2.D_1, D_2);
function B (Obj : Par_2; X : Integer; Y : Integer) return Boolean;
type Deriv_2 (<>) is tagged private;
-- DIC calls: B (Par_2, Par_2.D_1, Par_2.D_2)
-- No overriding
-- Renaming
-- Visible derivation
type Par_3 (D_1 : Integer; D_2 : Integer) is tagged private
with Default_Initial_Condition => C (Par_3, Par_3.D_1, D_2);
function C (Obj : Par_3; X : Integer; Y : Integer) return Boolean;
type Deriv_3 (D_2 : Integer; D_3 : Integer) is new Par_3 with private;
-- D_2 renames Par_3.D_2
-- D_3 renames Par_3.D_1
-- DIC calls: C (Par_3, Deriv_3.D_3, Deriv_3.D_2)
-- No overriding
-- Renaming
-- Hidden derivation
type Par_4 (D_1 : Integer; D_2 : Integer) is tagged private
with Default_Initial_Condition => D (Par_4, Par_4.D_1, D_2);
function D (Obj : Par_4; X : Integer; Y : Integer) return Boolean;
type Deriv_4 (D_1 : Integer; D_3 : Integer) is private;
-- D_1 renames Par_4.D_1
-- D_3 renames Par_4.D_2
-- DIC calls: D (Par_4, Deriv_4.D_1, Deriv_4.D_3)
-- No overriding
-- Girder
-- Visible derivation
type Par_5 (D_1 : Integer; D_2 : Integer) is tagged private
with Default_Initial_Condition => E (Par_5, Par_5.D_1, D_2);
function E (Obj : Par_5; X : Integer; Y : Integer) return Boolean;
type Deriv_5 (D_3 : Integer; D_4 : Integer) is new Par_5 with private;
-- Par_5.D_1 constrained to 123
-- Par_5.D_2 constrained to 456
-- DIC calls: E (Par_5, 123, 456)
-- No overriding
-- Girder
-- Hidden derivation
type Par_6 (D_1 : Integer; D_2 : Integer) is tagged private
with Default_Initial_Condition => F (Par_6, Par_6.D_1, D_2);
function F (Obj : Par_6; X : Integer; Y : Integer) return Boolean;
type Deriv_6 is tagged private;
-- Par_6.D_1 constrained to 123
-- Par_6.D_2 constrained to 456
-- DIC calls: F (Par_6, 123, 456)
-- Overriding
-- No discriminants
-- Visible derivation
type Par_7 (D_1 : Integer; D_2 : Integer) is tagged private
with Default_Initial_Condition => G (Par_7, Par_7.D_1, D_2);
function G (Obj : Par_7; X : Integer; Y : Integer) return Boolean;
type Deriv_7 is new Par_7 with private;
-- DIC calls: G (Deriv_7, Par_7.D_1, Par_7.D_2)
function G (Obj : Deriv_7; X : Integer; Y : Integer) return Boolean;
-- Overriding
-- No discriminants
-- Hidden derivation
type Par_8 (D_1 : Integer; D_2 : Integer) is tagged private
with Default_Initial_Condition => H (Par_8, Par_8.D_1, D_2);
function H (Obj : Par_8; X : Integer; Y : Integer) return Boolean;
type Deriv_8 (<>) is tagged private;
-- DIC calls: H (Deriv_8, Par_8.D_1, Par_8.D_2);
function H (Obj : Deriv_8; X : Integer; Y : Integer) return Boolean;
-- Overriding
-- Renaming
-- Visible derivation
type Par_9 (D_1 : Integer; D_2 : Integer) is tagged private
with Default_Initial_Condition => I (Par_9, Par_9.D_1, D_2);
function I (Obj : Par_9; X : Integer; Y : Integer) return Boolean;
type Deriv_9 (D_2 : Integer; D_1 : Integer) is new Par_9 with private;
-- D_2 renames Par_9.D_1
-- D_1 renames Par_9.D_2
-- DIC calls: I (Deriv_9, Deriv_9.D_2, Deriv_9.D_1)
function I (Obj : Deriv_9; X : Integer; Y : Integer) return Boolean;
-- Overriding
-- Renaming
-- Hidden derivation
type Par_10 (D_1 : Integer; D_2 : Integer) is tagged private
with Default_Initial_Condition => J (Par_10, Par_10.D_1, D_2);
function J (Obj : Par_10; X : Integer; Y : Integer) return Boolean;
type Deriv_10 (D_1 : Integer; D_4 : Integer) is tagged private;
-- D_1 renames Par_10.D_2
-- D_4 renames Par_10.D_1
-- DIC calls: J (Deriv_10, Deriv_10.D_4, Deriv_10.D_1)
function J (Obj : Deriv_10; X : Integer; Y : Integer) return Boolean;
-- Overriding
-- Girder
-- Visible derivation
type Par_11 (D_1 : Integer; D_2 : Integer) is tagged private
with Default_Initial_Condition => K (Par_11, Par_11.D_1, D_2);
function K (Obj : Par_11; X : Integer; Y : Integer) return Boolean;
type Deriv_11 (D_3 : Integer) is new Par_11 with private;
-- Par_11.D_1 constained to 123
-- Par_11.D_2 constained to 456
-- DIC calls: K (Deriv_11, 123, 456)
function K (Obj : Deriv_11; X : Integer; Y : Integer) return Boolean;
-- Overriding
-- Girder
-- Hidden derivation
type Par_12 (D_1 : Integer; D_2 : Integer) is tagged private
with Default_Initial_Condition => L (Par_12, Par_12.D_1, D_2);
function L (Obj : Par_12; X : Integer; Y : Integer) return Boolean;
type Deriv_12 (<>) is tagged private;
-- Par_12.D_1 constrained to 123
-- Par_12.D_2 constrained to 456
-- DIC calls: L (Deriv_12, 123, 456)
function L (Obj : Deriv_12; X : Integer; Y : Integer) return Boolean;
------------------------------------------
-- 3) Tagged derivations, special cases --
------------------------------------------
-- Long chain
-- Overriding
-- Renaming + Girder
-- Mixed derivation
type Par_13 (D_1 : Integer; D_2 : Integer) is tagged private
with Default_Initial_Condition => M (Par_13, Par_13.D_1, D_2);
function M (Obj : Par_13; X : Integer; Y : Integer) return Boolean;
type Mid_13 (D_3 : Integer) is new Par_13 with private;
-- Par_13.D_1 constrained to 123
-- D_3 renames Par_13.D_2
-- DIC calls: M (Par_13, 123, Mid_13.D_3)
type Deriv_13 (D_1 : Integer) is tagged private;
-- D_1 renames Mid_13.D_3
-- DIC calls: M (Deriv_13, 123, Deriv_13.D_1)
function M (Obj : Deriv_13; X : Integer; Y : Integer) return Boolean;
-- Long chain
-- Overriding
-- Renaming
-- Mixed derivation
type Par_14 (D_1 : Integer; D_2 : Integer) is tagged private
with Default_Initial_Condition => N (Par_14, Par_14.D_1, D_2);
function N (Obj : Par_14; X : Integer; Y : Integer) return Boolean;
type Mid_14 (<>) is tagged private;
-- inherits Par_14.D_1
-- inherits Par_14.D_2
-- DIC calls: N (Mid_14, Par_14.D_1, Par_14.D_2)
function N (Obj : Mid_14; X : Integer; Y : Integer) return Boolean;
type Deriv_14 (D_2 : Integer; D_3 : Integer) is new Mid_14 with private;
-- Deriv_14.D_2 renames Mid_14.D_2
-- Deriv_14.D_3 renames Mid_14.D_1
-- DIC calls: N (Deriv_14, Deriv_14.D_3, Deriv_14.D_2)
function N (Obj : Deriv_14; X : Integer; Y : Integer) return Boolean;
-- Overriding
-- Renaming + fewer discriminants
-- Visible derivation
type Par_15 (D_1 : Integer; D_2 : Integer) is tagged private
with Default_Initial_Condition => O (Par_15, Par_15.D_1, D_2);
function O (Obj : Par_15; X : Integer; Y : Integer) return Boolean;
type Deriv_15 (D_3 : Integer) is new Par_15 with private;
-- Deriv_15.D_3 constrains Par_15.D_1 and Par_15.D_2
-- DIC calls: O (Deriv_15, Deriv_15.D_3, Deriv_15.D_3)
function O (Obj : Deriv_15; X : Integer; Y : Integer) return Boolean;
-----------------------------
-- 4) Untagged derivations --
-----------------------------
-- Inheritance
-- No discriminants
type Par_16 (D_1 : Integer; D_2 : Integer) is private
with Default_Initial_Condition => P (Par_16, Par_16.D_1, D_2);
function P (Obj : Par_16; X : Integer; Y : Integer) return Boolean;
-- Inheritance
-- Renaming
type Par_17 (D_1 : Integer; D_2 : Integer) is private
with Default_Initial_Condition => Q (Par_17, Par_17.D_1, D_2);
function Q (Obj : Par_17; X : Integer; Y : Integer) return Boolean;
-- Inheritance
-- Girder
type Par_18 (D_1 : Integer; D_2 : Integer) is private
with Default_Initial_Condition => R (Par_18, Par_18.D_1, D_2);
function R (Obj : Par_18; X : Integer; Y : Integer) return Boolean;
--------------------------------------------
-- 5) Untagged derivations, special cases --
--------------------------------------------
-- Long chain
-- Inheritance
-- Renaming + Girder
type Par_19 (D_1 : Integer; D_2 : Integer) is private
with Default_Initial_Condition => S (Par_19, Par_19.D_1, D_2);
function S (Obj : Par_19; X : Integer; Y : Integer) return Boolean;
-- Inheritance
-- Renaming + fewer discriminants
type Par_20 (D_1 : Integer; D_2 : Integer) is private
with Default_Initial_Condition => T (Par_20, Par_20.D_1, D_2);
function T (Obj : Par_20; X : Integer; Y : Integer) return Boolean;
procedure Test_Deriv_2;
procedure Test_Deriv_6;
procedure Test_Deriv_8;
procedure Test_Deriv_12;
procedure Test_Deriv_16;
procedure Test_Deriv_17;
procedure Test_Deriv_18;
procedure Test_Deriv_19;
procedure Test_Deriv_20;
procedure Test_DN_Deriv_14;
procedure Test_Mid_14;
procedure Test_Mid_19;
private
type No_Deriv_1 (D_1 : Integer; D_2 : Integer) is null record;
type No_Deriv_2 (D_1 : Integer; D_2 : Integer) is tagged null record;
type Par_1 (D_1 : Integer; D_2 : Integer) is tagged null record;
type Deriv_1 is new Par_1 with null record;
type Par_2 (D_1 : Integer; D_2 : Integer) is tagged null record;
type Deriv_2 is new Par_2 with null record;
type Par_3 (D_1 : Integer; D_2 : Integer) is tagged null record;
type Deriv_3 (D_2 : Integer; D_3 : Integer) is
new Par_3 (D_1 => D_3, D_2 => D_2) with null record;
type Par_4 (D_1 : Integer; D_2 : Integer) is tagged null record;
type Deriv_4 (D_1 : Integer; D_3 : Integer) is
new Par_4 (D_1 => D_1, D_2 => D_3) with null record;
type Par_5 (D_1 : Integer; D_2 : Integer) is tagged null record;
type Deriv_5 (D_3 : Integer; D_4 : Integer) is
new Par_5 (D_1 => 123, D_2 => 456) with null record;
type Par_6 (D_1 : Integer; D_2 : Integer) is tagged null record;
type Deriv_6 is new Par_6 (D_1 => 123, D_2 => 456) with null record;
type Par_7 (D_1 : Integer; D_2 : Integer) is tagged null record;
type Deriv_7 is new Par_7 with null record;
type Par_8 (D_1 : Integer; D_2 : Integer) is tagged null record;
type Deriv_8 is new Par_8 with null record;
type Par_9 (D_1 : Integer; D_2 : Integer) is tagged null record;
type Deriv_9 (D_2 : Integer; D_1 : Integer) is
new Par_9 (D_1 => D_2, D_2 => D_1) with null record;
type Par_10 (D_1 : Integer; D_2 : Integer) is tagged null record;
type Deriv_10 (D_1 : Integer; D_4 : Integer) is
new Par_10 (D_1 => D_4, D_2 => D_1) with null record;
type Par_11 (D_1 : Integer; D_2 : Integer) is tagged null record;
type Deriv_11 (D_3 : Integer) is
new Par_11 (D_1 => 123, D_2 => 456) with null record;
type Par_12 (D_1 : Integer; D_2 : Integer) is tagged null record;
type Deriv_12 is new Par_12 (D_1 => 123, D_2 => 456) with null record;
type Par_13 (D_1 : Integer; D_2 : Integer) is tagged null record;
type Mid_13 (D_3 : Integer) is
new Par_13 (D_1 => 123, D_2 => D_3) with null record;
type Deriv_13 (D_1 : Integer) is new Mid_13 (D_3 => D_1) with null record;
type Par_14 (D_1 : Integer; D_2 : Integer) is tagged null record;
type Mid_14 is new Par_14 with null record;
type Deriv_14 (D_2 : Integer; D_3 : Integer) is
new Mid_14 (D_1 => D_3, D_2 => D_2) with null record;
type Par_15 (D_1 : Integer; D_2 : Integer) is tagged null record;
type Deriv_15 (D_3 : Integer) is
new Par_15 (D_1 => D_3, D_2 => D_3) with null record;
-----------------------------
-- 4) Untagged derivations --
-----------------------------
-- Inheritance
-- No discriminants
type Par_16 (D_1 : Integer; D_2 : Integer) is null record;
type Deriv_16 is new Par_16;
-- DIC calls: P (Par_16, Par_16.D_1, Par_16.D_2)
-- Inheritance
-- Renaming
type Par_17 (D_1 : Integer; D_2 : Integer) is null record;
type Deriv_17 (D_2 : Integer; D_3 : Integer) is
new Par_17 (D_1 => D_3, D_2 => D_2);
-- Deriv_17.D_2 renames Par_17.D_2
-- Deriv_17.D_3 renames Par_17.D_1
-- DIC calls: Q (Par_17, Deriv_17.D_3, Deriv_17.D_2)
-- Inheritance
-- Girder
type Par_18 (D_1 : Integer; D_2 : Integer) is null record;
type Deriv_18 is new Par_18 (D_1 => 123, D_2 => 456);
-- Par_18.D_1 constrained by 123
-- Par_18.D_2 constrained by 456
-- DIC calls: R (Par_18, 123, 456)
--------------------------------------------
-- 5) Untagged derivations, special cases --
--------------------------------------------
-- Long chain
-- Inheritance
-- Renaming + Girder
type Par_19 (D_1 : Integer; D_2 : Integer) is null record;
type Mid_19 (D_3 : Integer) is new Par_19 (D_1 => 123, D_2 => D_3);
-- Par_19.D_1 constrained by 123
-- Mid_19.D_3 renames Par_19.D_2
-- DIC calls: R (Par_19, 123, Mid_19.D_3)
type Deriv_19 (D_1 : Integer) is new Mid_19 (D_1);
-- Deriv_19.D_1 renames Mid_19.D_3
-- DIC calls: R (Par_19, 123, Deriv_19.D_1)
-- Inheritance
-- Renaming + fewer discriminants
type Par_20 (D_1 : Integer; D_2 : Integer) is null record;
type Deriv_20 (D_3 : Integer) is new Par_20 (D_1 => D_3, D_2 => D_3);
-- Deriv_20.D_3 constrains Par_20.D_1 and Par_20.D_2
-- DIC calls: T (Par_20, Deriv_20.D_3, Deriv_20.D_3)
end DIC_Pack1;
-- dic_pack1.adb
with DIC_Generic;
with Tester; use Tester;
package body DIC_Pack1 is
function A (Obj : Par_1; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_1_Id, X, Y);
return True;
end A;
function B (Obj : Par_2; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_2_Id, X, Y);
return True;
end B;
function C (Obj : Par_3; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_3_Id, X, Y);
return True;
end C;
function D (Obj : Par_4; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_4_Id, X, Y);
return True;
end D;
function E (Obj : Par_5; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_5_Id, X, Y);
return True;
end E;
function F (Obj : Par_6; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_6_Id, X, Y);
return True;
end F;
function G (Obj : Par_7; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_7_Id, X, Y);
return True;
end G;
function G (Obj : Deriv_7; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_7_Id, X, Y);
return True;
end G;
function H (Obj : Par_8; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_8_Id, X, Y);
return True;
end H;
function H (Obj : Deriv_8; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_8_Id, X, Y);
return True;
end H;
function I (Obj : Par_9; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_9_Id, X, Y);
return True;
end I;
function I (Obj : Deriv_9; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_9_Id, X, Y);
return True;
end I;
function J (Obj : Par_10; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_10_Id, X, Y);
return True;
end J;
function J (Obj : Deriv_10; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_10_Id, X, Y);
return True;
end J;
function K (Obj : Par_11; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_11_Id, X, Y);
return True;
end K;
function K (Obj : Deriv_11; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_11_Id, X, Y);
return True;
end K;
function L (Obj : Par_12; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_12_Id, X, Y);
return True;
end L;
function L (Obj : Deriv_12; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_12_Id, X, Y);
return True;
end L;
function M (Obj : Par_13; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_13_Id, X, Y);
return True;
end M;
function M (Obj : Deriv_13; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_13_Id, X, Y);
return True;
end M;
function N (Obj : Par_14; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_14_Id, X, Y);
return True;
end N;
function N (Obj : Mid_14; X : Integer; Y : Integer) return Boolean is
begin
Mark (Mid_14_Id, X, Y);
return True;
end N;
function N (Obj : Deriv_14; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_14_Id, X, Y);
return True;
end N;
function O (Obj : Par_15; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_15_Id, X, Y);
return True;
end O;
function O (Obj : Deriv_15; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_15_Id, X, Y);
return True;
end O;
function P (Obj : Par_16; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_16_Id, X, Y);
return True;
end P;
function Q (Obj : Par_17; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_17_Id, X, Y);
return True;
end Q;
function R (Obj : Par_18; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_18_Id, X, Y);
return True;
end R;
function S (Obj : Par_19; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_19_Id, X, Y);
return True;
end S;
function T (Obj : Par_20; X : Integer; Y : Integer) return Boolean is
begin
Mark (Par_20_Id, X, Y);
return True;
end T;
procedure Test_Deriv_2 is
Obj : Deriv_2 (2, 22);
begin null; end Test_Deriv_2;
procedure Test_Deriv_6 is
Obj : Deriv_6;
begin null; end Test_Deriv_6;
procedure Test_Deriv_8 is
Obj : Deriv_8 (8, 88);
begin null; end Test_Deriv_8;
procedure Test_Deriv_12 is
Obj : Deriv_12;
begin null; end Test_Deriv_12;
procedure Test_Deriv_16 is
Obj : Deriv_16 (16, 1616);
begin null; end Test_Deriv_16;
procedure Test_Deriv_17 is
Obj : Deriv_17 (17, 1717);
begin null; end Test_Deriv_17;
procedure Test_Deriv_18 is
Obj : Deriv_18;
begin null; end Test_Deriv_18;
procedure Test_Deriv_19 is
Obj : Deriv_19 (1919);
begin null; end Test_Deriv_19;
procedure Test_Deriv_20 is
Obj : Deriv_20 (20);
begin null; end Test_Deriv_20;
procedure Test_DN_Deriv_14 is
procedure Gen_14 is new DIC_Generic (Deriv_14);
begin
Gen_14 (14, 1414);
end Test_DN_Deriv_14;
procedure Test_Mid_14 is
Obj : Mid_14 (14, 1414);
begin null; end Test_Mid_14;
procedure Test_Mid_19 is
Obj : Mid_19 (19);
begin null; end Test_Mid_19;
end DIC_Pack1;
-- dic_generic.ads
generic
type Formal (FD_1 : Integer; FD_2 : Integer) is private;
procedure DIC_Generic (X : Integer; Y : Integer);
-- dic_generic.adb
procedure DIC_Generic (X : Integer; Y : Integer) is
Obj : Formal (X, Y);
pragma Warnings (Off, Obj);
begin null; end DIC_Generic;
-- dic_pack2.ads
with DIC_Pack1; use DIC_Pack1;
package DIC_Pack2 is
---------------------------
-- 1) Tagged derivations --
---------------------------
-- No overriding
-- No discriminants
-- Visible derivation
type Deriv_21 is new Par_1 with private;
-- DIC calls A (Par_1, Par_1.D_1, Par_1.D_2)
-- No overriding
-- Unknown discriminants
-- Hidden derivation
type Deriv_22 (<>) is tagged private;
-- DIC calls: B (Par_2, Par_2.D_1, Par_2.D_2)
-- No overriding
-- Renaming
-- Visible derivation
type Deriv_23 (D_2 : Integer; D_3 : Integer) is new Par_3 with private;
-- D_2 renames Par_3.D_2
-- D_3 renames Par_3.D_1
-- DIC calls: C (Par_3, Deriv_3.D_3, Deriv_3.D_2)
-- No overriding
-- Renaming
-- Hidden derivation
type Deriv_24 (D_1 : Integer; D_3 : Integer) is private;
-- D_1 renames Par_4.D_1
-- D_3 renames Par_4.D_2
-- DIC calls: D (Par_4, Deriv_4.D_1, Deriv_4.D_3)
-- No overriding
-- Girder
-- Visible derivation
type Deriv_25 (D_3 : Integer; D_4 : Integer) is new Par_5 with private;
-- Par_5.D_1 constrained to 123
-- Par_5.D_2 constrained to 456
-- DIC calls: E (Par_5, 123, 456)
-- No overriding
-- Girder
-- Hidden derivation
type Deriv_26 is tagged private;
-- Par_6.D_1 constrained to 123
-- Par_6.D_2 constrained to 456
-- DIC calls: F (Par_6, 123, 456)
-- Overriding
-- No discriminants
-- Visible derivation
type Deriv_27 is new Par_7 with private;
-- DIC calls: G (Deriv_27, Par_7.D_1, Par_7.D_2)
function G (Obj : Deriv_27; X : Integer; Y : Integer) return Boolean;
-- Overriding
-- No discriminants
-- Hidden derivation
type Deriv_28 (<>) is tagged private;
-- DIC calls: H (Deriv_28, Par_8.D_1, Par_8.D_2);
function H (Obj : Deriv_28; X : Integer; Y : Integer) return Boolean;
-- Overriding
-- Renaming
-- Visible derivation
type Deriv_29 (D_2 : Integer; D_1 : Integer) is new Par_9 with private;
-- D_2 renames Par_9.D_1
-- D_1 renames Par_9.D_2
-- DIC calls: I (Deriv_29, Deriv_29.D_2, Deriv_29.D_1)
function I (Obj : Deriv_29; X : Integer; Y : Integer) return Boolean;
-- Overriding
-- Renaming
-- Hidden derivation
type Deriv_30 (D_1 : Integer; D_4 : Integer) is tagged private;
-- D_1 renames Par_10.D_2
-- D_4 renames Par_10.D_1
-- DIC calls: J (Deriv_30, Deriv_30.D_4, Deriv_30.D_1)
function J (Obj : Deriv_30; X : Integer; Y : Integer) return Boolean;
-- Overriding
-- Girder
-- Visible derivation
type Deriv_31 (D_3 : Integer) is new Par_11 with private;
-- Par_11.D_1 constained to 123
-- Par_11.D_2 constained to 456
-- DIC calls: K (Deriv_31, 123, 456)
function K (Obj : Deriv_31; X : Integer; Y : Integer) return Boolean;
-- Overriding
-- Girder
-- Hidden derivation
type Deriv_32 (<>) is tagged private;
-- Par_12.D_1 constrained to 123
-- Par_12.D_2 constrained to 456
-- DIC calls: L (Deriv_32, 123, 456)
function L (Obj : Deriv_32; X : Integer; Y : Integer) return Boolean;
------------------------------------------
-- 2) Tagged derivations, special cases --
------------------------------------------
-- Long chain
-- Renaming + Girder
-- Mixed derivation
type Mid_33 (D_3 : Integer) is new Par_13 with private;
-- Par_13.D_1 constrained to 123
-- D_3 renames Par_13.D_2
-- DIC calls: M (Par_13, 123, Mid_33.D_3)
type Deriv_33 (D_1 : Integer) is tagged private;
-- D_1 renames Mid_33.D_3
-- DIC calls: M (Deriv_33, 123, Deriv_33.D_1)
function M (Obj : Deriv_33; X : Integer; Y : Integer) return Boolean;
-- Long chain
-- Overriding
-- Renaming
-- Hidden derivation
type Mid_34 (<>) is tagged private;
-- inherits Par_14.D_1
-- inherits Par_14.D_2
-- DIC calls: N (Mid_34, Par_14.D_1, Par_14.D_2)
function N (Obj : Mid_34; X : Integer; Y : Integer) return Boolean;
type Deriv_34 (D_2 : Integer; D_3 : Integer) is tagged private;
-- Deriv_34.D_2 renames Mid_34.D_2
-- Deriv_34.D_3 renames Mid_34.D_1
-- DIC calls: N (Deriv_34, Deriv_34.D_3, Deriv_34.D_2)
function N (Obj : Deriv_34; X : Integer; Y : Integer) return Boolean;
-- Overriding
-- Renaming + fewer discriminants
-- Visible derivation
type Deriv_35 (D_3 : Integer) is new Par_15 with private;
-- Deriv_35.D_3 constrains Par_15.D_1 and Par_15.D_2
-- DIC calls: O (Deriv_35, Deriv_35.D_3, Deriv_35.D_3)
function O (Obj : Deriv_35; X : Integer; Y : Integer) return Boolean;
-----------------------------
-- 3) Untagged derivations --
-----------------------------
-- Inheritance
-- No discriminants
type Deriv_36 is new Par_16;
-- DIC calls: P (Par_16, Par_16.D_1, Par_16.D_2)
-- Inheritance
-- Renaming
type Deriv_37 (D_2 : Integer; D_3 : Integer) is
new Par_17 (D_1 => D_3, D_2 => D_2);
-- Deriv_37.D_2 renames Par_17.D_2
-- Deriv_37.D_3 renames Par_17.D_1
-- DIC calls: Q (Par_17, Deriv_37.D_3, Deriv_37.D_2)
-- Inheritance
-- Girder
type Deriv_38 is new Par_18 (D_1 => 123, D_2 => 456);
-- Par_38.D_1 constrained by 123
-- Par_38.D_2 constrained by 456
-- DIC calls: R (Par_38, 123, 456)
--------------------------------------------
-- 4) Untagged derivations, special cases --
--------------------------------------------
-- Long chain
-- Inheritance
-- Renaming + Girder
type Mid_39 (D_3 : Integer) is new Par_19 (D_1 => 123, D_2 => D_3);
-- Par_19.D_1 constrained by 123
-- Mid_39.D_3 renames Par_19.D_2
-- DIC calls: R (Par_19, 123, Mid_39.D_3)
type Deriv_39 (D_1 : Integer) is new Mid_39 (D_1);
-- Deriv_39.D_1 renames Mid_39.D_3
-- DIC calls: R (Par_19, 123, Deriv_39.D_1)
-- Inheritance
-- Renaming + fewer discriminants
type Deriv_40 (D_3 : Integer) is new Par_20 (D_1 => D_3, D_2 => D_3);
-- Deriv_40.D_3 constrains Par_20.D_1 and Par_20.D_2
-- DIC calls: T (Par_20, Deriv_40.D_3, Deriv_40.D_3)
procedure Test_Deriv_22;
procedure Test_Deriv_28;
procedure Test_Deriv_32;
procedure Test_Mid_34;
private
type Deriv_21 is new Par_1 with null record;
type Deriv_22 is new Par_2 with null record;
type Deriv_23 (D_2 : Integer; D_3 : Integer) is
new Par_3 (D_1 => D_3, D_2 => D_2) with null record;
type Deriv_24 (D_1 : Integer; D_3 : Integer) is
new Par_4 (D_1 => D_1, D_2 => D_3) with null record;
type Deriv_25 (D_3 : Integer; D_4 : Integer) is
new Par_5 (D_1 => 123, D_2 => 456) with null record;
type Deriv_26 is new Par_6 (D_1 => 123, D_2 => 456) with null record;
type Deriv_27 is new Par_7 with null record;
type Deriv_28 is new Par_8 with null record;
type Deriv_29 (D_2 : Integer; D_1 : Integer) is
new Par_9 (D_1 => D_2, D_2 => D_1) with null record;
type Deriv_30 (D_1 : Integer; D_4 : Integer) is
new Par_10 (D_1 => D_4, D_2 => D_1) with null record;
type Deriv_31 (D_3 : Integer) is
new Par_11 (D_1 => 123, D_2 => 456) with null record;
type Deriv_32 is new Par_12 (D_1 => 123, D_2 => 456) with null record;
type Mid_33 (D_3 : Integer) is
new Par_13 (D_1 => 123, D_2 => D_3) with null record;
type Deriv_33 (D_1 : Integer) is new Mid_33 (D_3 => D_1) with null record;
type Mid_34 is new Par_14 with null record;
type Deriv_34 (D_2 : Integer; D_3 : Integer) is
new Mid_34 (D_1 => D_3, D_2 => D_2) with null record;
type Deriv_35 (D_3 : Integer) is
new Par_15 (D_1 => D_3, D_2 => D_3) with null record;
end DIC_Pack2;
-- dic_pack2.adb
with Tester; use Tester;
package body DIC_Pack2 is
function G (Obj : Deriv_27; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_27_Id, X, Y);
return True;
end G;
function H (Obj : Deriv_28; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_28_Id, X, Y);
return True;
end H;
function I (Obj : Deriv_29; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_29_Id, X, Y);
return True;
end I;
function J (Obj : Deriv_30; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_30_Id, X, Y);
return True;
end J;
function K (Obj : Deriv_31; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_31_Id, X, Y);
return True;
end K;
function L (Obj : Deriv_32; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_32_Id, X, Y);
return True;
end L;
function M (Obj : Deriv_33; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_33_Id, X, Y);
return True;
end M;
function N (Obj : Mid_34; X : Integer; Y : Integer) return Boolean is
begin
Mark (Mid_34_Id, X, Y);
return True;
end N;
function N (Obj : Deriv_34; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_34_Id, X, Y);
return True;
end N;
function O (Obj : Deriv_35; X : Integer; Y : Integer) return Boolean is
begin
Mark (Deriv_35_Id, X, Y);
return True;
end O;
procedure Test_Deriv_22 is
Obj : Deriv_22 (22, 2222);
begin null; end Test_Deriv_22;
procedure Test_Deriv_28 is
Obj : Deriv_28 (28, 2828);
begin null; end Test_Deriv_28;
procedure Test_Deriv_32 is
Obj : Deriv_32;
begin null; end Test_Deriv_32;
procedure Test_Mid_34 is
Obj : Mid_34 (34, 3434);
begin null; end Test_Mid_34;
end DIC_Pack2;
-- dic_main.adb
with DIC_Pack1; use DIC_Pack1;
with DIC_Pack2; use DIC_Pack2;
with Tester; use Tester;
procedure DIC_Main is
begin
Reset_Results;
declare
Obj : Deriv_1 (1, 11);
begin
Test_Result ("Deriv_1", (Par_1_Id => (1, 11),
others => No_Result));
end;
Reset_Results;
Test_Deriv_2;
Test_Result ("Deriv_2", (Par_2_Id => (2, 22),
others => No_Result));
Reset_Results;
declare
Obj : Deriv_3 (3, 33);
begin
Test_Result ("Deriv_3", (Par_3_Id => (33, 3),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_4 (4, 44);
begin
Test_Result ("Deriv_4", (Par_4_Id => (4, 44),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_5 (5, 55);
begin
Test_Result ("Deriv_5", (Par_5_Id => (123, 456),
others => No_Result));
end;
Reset_Results;
Test_Deriv_6;
Test_Result ("Deriv_6", (Par_6_Id => (123, 456),
others => No_Result));
Reset_Results;
declare
Obj : Deriv_7 (7, 77);
begin
Test_Result ("Deriv_7", (Deriv_7_Id => (7, 77),
others => No_Result));
end;
Reset_Results;
Test_Deriv_8;
Test_Result ("Deriv_8", (Deriv_8_Id => (8, 88),
others => No_Result));
Reset_Results;
declare
Obj : Deriv_9 (9, 99);
begin
Test_Result ("Deriv_9", (Deriv_9_Id => (9, 99),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_10 (10, 1010);
begin
Test_Result ("Deriv_10", (Deriv_10_Id => (1010, 10),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_11 (11);
begin
Test_Result ("Deriv_11", (Deriv_11_Id => (123, 456),
others => No_Result));
end;
Reset_Results;
Test_Deriv_12;
Test_Result ("Deriv_12", (Deriv_12_Id => (123, 456),
others => No_Result));
Reset_Results;
declare
Obj : Mid_13 (13);
begin
Test_Result ("Mid_13", (Par_13_Id => (123, 13),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_13 (1313);
begin
Test_Result ("Deriv_13", (Deriv_13_Id => (123, 1313),
others => No_Result));
end;
Reset_Results;
Test_Mid_14;
Test_Result ("Mid_14", (Mid_14_Id => (14, 1414),
others => No_Result));
Reset_Results;
declare
Obj : Deriv_14 (14, 1414);
begin
Test_Result ("Deriv_14", (Deriv_14_Id => (1414, 14),
others => No_Result));
end;
Reset_Results;
Test_DN_Deriv_14;
Test_Result ("Deriv_14_DN", (Deriv_14_Id => (1414, 14),
others => No_Result));
Reset_Results;
declare
Obj : Deriv_15 (15);
begin
Test_Result ("Deriv_15", (Deriv_15_Id => (15, 15),
others => No_Result));
end;
Reset_Results;
Test_Deriv_16;
Test_Result ("Deriv_16", (Par_16_Id => (16, 1616),
others => No_Result));
Reset_Results;
Test_Deriv_17;
Test_Result ("Deriv_17", (Par_17_Id => (1717, 17),
others => No_Result));
Reset_Results;
Test_Deriv_18;
Test_Result ("Deriv_18", (Par_18_Id => (123, 456),
others => No_Result));
Reset_Results;
Test_Mid_19;
Test_Result ("Mid_19", (Par_19_Id => (123, 19),
others => No_Result));
Reset_Results;
Test_Deriv_19;
Test_Result ("Deriv_19", (Par_19_Id => (123, 1919),
others => No_Result));
Reset_Results;
Test_Deriv_20;
Test_Result ("Deriv_20", (Par_20_Id => (20, 20),
others => No_Result));
Reset_Results;
declare
Obj : Deriv_21 (21, 2121);
begin
Test_Result ("Deriv_21", (Par_1_Id => (21, 2121),
others => No_Result));
end;
Reset_Results;
Test_Deriv_22;
Test_Result ("Deriv_22", (Par_2_Id => (22, 2222),
others => No_Result));
Reset_Results;
declare
Obj : Deriv_23 (23, 2323);
begin
Test_Result ("Deriv_23", (Par_3_Id => (2323, 23),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_24 (24, 2424);
begin
Test_Result ("Deriv_24", (Par_4_Id => (24, 2424),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_25 (25, 2525);
begin
Test_Result ("Deriv_25", (Par_5_Id => (123, 456),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_26;
begin
Test_Result ("Deriv_26", (Par_6_Id => (123, 456),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_27 (27, 2727);
begin
Test_Result ("Deriv_27", (Deriv_27_Id => (27, 2727),
others => No_Result));
end;
Reset_Results;
Test_Deriv_28;
Test_Result ("Deriv_28", (Deriv_28_Id => (28, 2828),
others => No_Result));
Reset_Results;
declare
Obj : Deriv_29 (29, 2929);
begin
Test_Result ("Deriv_29", (Deriv_29_Id => (29, 2929),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_30 (30, 3030);
begin
Test_Result ("Deriv_30", (Deriv_30_Id => (3030, 30),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_31 (31);
begin
Test_Result ("Deriv_31", (Deriv_31_Id => (123, 456),
others => No_Result));
end;
Reset_Results;
Test_Deriv_32;
Test_Result ("Deriv_32", (Deriv_32_Id => (123, 456),
others => No_Result));
Reset_Results;
declare
Obj : Mid_33 (33);
begin
Test_Result ("Mid_33", (Par_13_Id => (123, 33),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_33 (3333);
begin
Test_Result ("Deriv_33", (Deriv_33_Id => (123, 3333),
others => No_Result));
end;
Reset_Results;
Test_Mid_34;
Test_Result ("Mid_34", (Mid_34_Id => (34, 3434),
others => No_Result));
Reset_Results;
declare
Obj : Deriv_34 (34, 3434);
begin
Test_Result ("Deriv_34", (Deriv_34_Id => (3434, 34),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_35 (35);
begin
Test_Result ("Deriv_35", (Deriv_35_Id => (35, 35),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_36 (36, 3636);
begin
Test_Result ("Deriv_36", (Par_16_Id => (36, 3636),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_37 (37, 3737);
begin
Test_Result ("Deriv_37", (Par_17_Id => (3737, 37),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_38;
begin
Test_Result ("Deriv_38", (Par_18_Id => (123, 456),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_39 (39);
begin
Test_Result ("Deriv_39", (Par_19_Id => (123, 39),
others => No_Result));
end;
Reset_Results;
declare
Obj : Deriv_40 (40);
begin
Test_Result ("Deriv_40", (Par_20_Id => (40, 40),
others => No_Result));
end;
end DIC_Main;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q -gnata dic_main.adb
$ ./dic_main
Deriv_1: OK
Deriv_2: OK
Deriv_3: OK
Deriv_4: OK
Deriv_5: OK
Deriv_6: OK
Deriv_7: OK
Deriv_8: OK
Deriv_9: OK
Deriv_10: OK
Deriv_11: OK
Deriv_12: OK
Mid_13: OK
Deriv_13: OK
Mid_14: OK
Deriv_14: OK
Deriv_14_DN: OK
Deriv_15: OK
Deriv_16: OK
Deriv_17: OK
Deriv_18: OK
Mid_19: OK
Deriv_19: OK
Deriv_20: OK
Deriv_21: OK
Deriv_22: OK
Deriv_23: OK
Deriv_24: OK
Deriv_25: OK
Deriv_26: OK
Deriv_27: OK
Deriv_28: OK
Deriv_29: OK
Deriv_30: OK
Deriv_31: OK
Deriv_32: OK
Mid_33: OK
Deriv_33: OK
Mid_34: OK
Deriv_34: OK
Deriv_35: OK
Deriv_36: OK
Deriv_37: OK
Deriv_38: OK
Deriv_39: OK
Deriv_40: OK
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* elists.ads, elists.adb (Prepend_Unique_Elmt): New routine.
* exp_ch3.adb (Freeze_Type): Signal the DIC body is created for
the purposes of freezing.
* exp_util.adb Update the documentation and structure of the
type map used in class-wide semantics of assertion expressions.
(Add_Inherited_Tagged_DIC): There is really no need to preanalyze
and resolve the triaged expression because all substitutions
refer to the proper entities. Update the replacement of
references.
(Build_DIC_Procedure_Body): Add formal parameter
For_Freeze. Add local variable Build_Body. Inherited DIC pragmas
are now only processed when freezing occurs. Build a body only
when one is needed.
(Entity_Hash): Removed.
(Map_Types): New routine.
(Replace_Object_And_Primitive_References): Removed.
(Replace_References): New routine.
(Replace_Type_References): Moved to the library level of Exp_Util.
(Type_Map_Hash): New routine.
(Update_Primitives_Mapping): Update the mapping call.
(Update_Primitives_Mapping_Of_Types): Removed.
* exp_util.ads (Build_DIC_Procedure_Body): Add formal
parameter For_Freeze and update the comment on usage.
(Map_Types): New routine.
(Replace_References): New routine.
(Replace_Type_References): Moved to the library level of Exp_Util.
(Update_Primitives_Mapping_Of_Types): Removed.
* sem_ch7.adb (Preserve_Full_Attributes): Propagate the DIC
properties of the private type to the full view in case the full
view derives from a parent type and inherits a DIC pragma.
* sem_prag.adb (Analyze_Pragma): Guard against a case where a
DIC pragma is placed at the top of a declarative region.
-------------- next part --------------
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 247143)
+++ exp_util.adb (working copy)
@@ -92,17 +92,27 @@
-- operations are mapped into the overriding operations of that current
-- type extension.
- Primitives_Mapping_Size : constant := 511;
+ -- The contents of the map are as follows:
- subtype Num_Primitives is Integer range 0 .. Primitives_Mapping_Size - 1;
- function Entity_Hash (E : Entity_Id) return Num_Primitives;
+ -- Key Value
- package Primitives_Mapping is new GNAT.HTable.Simple_HTable
- (Header_Num => Num_Primitives,
+ -- Discriminant (Entity_Id) Discriminant (Entity_Id)
+ -- Discriminant (Entity_Id) Non-discriminant name (Entity_Id)
+ -- Discriminant (Entity_Id) Expression (Node_Id)
+ -- Primitive subprogram (Entity_Id) Primitive subprogram (Entity_Id)
+ -- Type (Entity_Id) Type (Entity_Id)
+
+ Type_Map_Size : constant := 511;
+
+ subtype Type_Map_Header is Integer range 0 .. Type_Map_Size - 1;
+ function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header;
+
+ package Type_Map is new GNAT.HTable.Simple_HTable
+ (Header_Num => Type_Map_Header,
Key => Entity_Id,
- Element => Entity_Id,
+ Element => Node_Or_Entity_Id,
No_element => Empty,
- Hash => Entity_Hash,
+ Hash => Type_Map_Hash,
Equal => "=");
-----------------------
@@ -1086,7 +1096,7 @@
-- Determine whether entity has a renaming
- New_E := Primitives_Mapping.Get (Entity (N));
+ New_E := Type_Map.Get (Entity (N));
if Present (New_E) then
Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
@@ -1172,7 +1182,7 @@
Subp_Formal := First_Formal (Subp);
while Present (Par_Formal) and then Present (Subp_Formal) loop
- Primitives_Mapping.Set (Par_Formal, Subp_Formal);
+ Type_Map.Set (Par_Formal, Subp_Formal);
Next_Formal (Par_Formal);
Next_Formal (Subp_Formal);
end loop;
@@ -1210,7 +1220,10 @@
-- replaced by gotos which jump to the end of the routine and restore the
-- Ghost mode.
- procedure Build_DIC_Procedure_Body (Typ : Entity_Id) is
+ procedure Build_DIC_Procedure_Body
+ (Typ : Entity_Id;
+ For_Freeze : Boolean := False)
+ is
procedure Add_DIC_Check
(DIC_Prag : Node_Id;
DIC_Expr : Node_Id;
@@ -1249,34 +1262,6 @@
-- DIC_Prag. DIC_Typ is the owner of the DIC pragma. All generated code
-- is added to list Stmts.
- procedure Replace_Object_And_Primitive_References
- (Expr : Node_Id;
- Par_Typ : Entity_Id;
- Deriv_Typ : Entity_Id;
- Par_Obj : Entity_Id := Empty;
- Deriv_Obj : Entity_Id := Empty);
- -- Expr denotes an arbitrary expression. Par_Typ is a parent type in a
- -- type hierarchy. Deriv_Typ is a type derived from Par_Typ. Par_Obj is
- -- the formal parameter which emulates the current instance of Par_Typ.
- -- Deriv_Obj is the formal parameter which emulates the current instance
- -- of Deriv_Typ. Perform the following substitutions:
- --
- -- * Replace a reference to Par_Obj with a reference to Deriv_Obj if
- -- applicable.
- --
- -- * Replace a call to an overridden parent primitive with a call to
- -- the overriding derived type primitive.
- --
- -- * Replace a call to an inherited parent primitive with a call to
- -- the internally-generated inherited derived type primitive.
-
- procedure Replace_Type_References
- (Expr : Node_Id;
- Typ : Entity_Id;
- Obj_Id : Entity_Id);
- -- Substitute all references of the current instance of type Typ with
- -- references to formal parameter Obj_Id within expression Expr.
-
-------------------
-- Add_DIC_Check --
-------------------
@@ -1358,7 +1343,6 @@
Deriv_Typ : Entity_Id;
Stmts : in out List_Id)
is
- Deriv_Decl : constant Node_Id := Declaration_Node (Deriv_Typ);
Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
DIC_Args : constant List_Id :=
Pragma_Argument_Associations (DIC_Prag);
@@ -1383,6 +1367,9 @@
-- type's DIC procedure with a reference to the _object parameter
-- of the derived types' DIC procedure.
+ -- * Replace a reference to a discriminant of the parent type with
+ -- a suitable value from the point of view of the derived type.
+
-- * Replace a call to an overridden parent primitive with a call
-- to the overriding derived type primitive.
@@ -1395,19 +1382,13 @@
pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
- Replace_Object_And_Primitive_References
+ Replace_References
(Expr => Expr,
Par_Typ => Par_Typ,
Deriv_Typ => Deriv_Typ,
Par_Obj => First_Formal (Par_Proc),
Deriv_Obj => First_Formal (Deriv_Proc));
- -- Preanalyze the DIC expression to detect errors and at the same
- -- time capture the visibility of the proper package part.
-
- Set_Parent (Expr, Deriv_Decl);
- Preanalyze_Assert_Expression (Expr, Any_Boolean);
-
-- Once the DIC assertion expression is fully processed, add a check
-- to the statements of the DIC procedure.
@@ -1531,200 +1512,6 @@
Stmts => Stmts);
end Add_Own_DIC;
- ---------------------------------------------
- -- Replace_Object_And_Primitive_References --
- ---------------------------------------------
-
- procedure Replace_Object_And_Primitive_References
- (Expr : Node_Id;
- Par_Typ : Entity_Id;
- Deriv_Typ : Entity_Id;
- Par_Obj : Entity_Id := Empty;
- Deriv_Obj : Entity_Id := Empty)
- is
- function Replace_Ref (Ref : Node_Id) return Traverse_Result;
- -- Substitute a reference to an entity with a reference to the
- -- corresponding entity stored in in table Primitives_Mapping.
-
- -----------------
- -- Replace_Ref --
- -----------------
-
- function Replace_Ref (Ref : Node_Id) return Traverse_Result is
- Context : constant Node_Id := Parent (Ref);
- Loc : constant Source_Ptr := Sloc (Ref);
- New_Id : Entity_Id;
- New_Ref : Node_Id;
- Ref_Id : Entity_Id;
- Result : Traverse_Result;
-
- begin
- Result := OK;
-
- -- The current node denotes a reference
-
- if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then
- Ref_Id := Entity (Ref);
- New_Id := Primitives_Mapping.Get (Ref_Id);
-
- -- The reference mentions a parent type primitive which has a
- -- corresponding derived type primitive.
-
- if Present (New_Id) then
- New_Ref := New_Occurrence_Of (New_Id, Loc);
-
- -- The reference mentions the _object parameter of the parent
- -- type's DIC procedure.
-
- elsif Present (Par_Obj)
- and then Present (Deriv_Obj)
- and then Ref_Id = Par_Obj
- then
- New_Ref := New_Occurrence_Of (Deriv_Obj, Loc);
-
- -- The reference to _object acts as an actual parameter in a
- -- subprogram call which may be invoking a primitive of the
- -- parent type:
-
- -- Primitive (... _object ...);
-
- -- The parent type primitive may not be overridden nor
- -- inherited when it is declared after the derived type
- -- definition:
-
- -- type Parent is tagged private;
- -- type Child is new Parent with private;
- -- procedure Primitive (Obj : Parent);
-
- -- In this scenario the _object parameter is converted to
- -- the parent type.
-
- if Nkind_In (Context, N_Function_Call,
- N_Procedure_Call_Statement)
- and then
- No (Primitives_Mapping.Get (Entity (Name (Context))))
- then
- New_Ref := Convert_To (Par_Typ, New_Ref);
-
- -- Do not process the generated type conversion because
- -- both the parent type and the derived type are in the
- -- Primitives_Mapping table. This will clobber the type
- -- conversion by resetting its subtype mark.
-
- Result := Skip;
- end if;
-
- -- Otherwise there is nothing to replace
-
- else
- New_Ref := Empty;
- end if;
-
- if Present (New_Ref) then
- Rewrite (Ref, New_Ref);
-
- -- Update the return type when the context of the reference
- -- acts as the name of a function call. Note that the update
- -- should not be performed when the reference appears as an
- -- actual in the call.
-
- if Nkind (Context) = N_Function_Call
- and then Name (Context) = Ref
- then
- Set_Etype (Context, Etype (New_Id));
- end if;
- end if;
- end if;
-
- -- Reanalyze the reference due to potential replacements
-
- if Nkind (Ref) in N_Has_Etype then
- Set_Analyzed (Ref, False);
- end if;
-
- return Result;
- end Replace_Ref;
-
- procedure Replace_Refs is new Traverse_Proc (Replace_Ref);
-
- -- Start of processing for Replace_Object_And_Primitive_References
-
- begin
- -- Map each primitive operation of the parent type to the proper
- -- primitive of the derived type.
-
- Update_Primitives_Mapping_Of_Types
- (Par_Typ => Par_Typ,
- Deriv_Typ => Deriv_Typ);
-
- -- Inspect the input expression and perform substitutions where
- -- necessary.
-
- Replace_Refs (Expr);
- end Replace_Object_And_Primitive_References;
-
- -----------------------------
- -- Replace_Type_References --
- -----------------------------
-
- procedure Replace_Type_References
- (Expr : Node_Id;
- Typ : Entity_Id;
- Obj_Id : Entity_Id)
- is
- procedure Replace_Type_Ref (N : Node_Id);
- -- Substitute a single reference of the current instance of type Typ
- -- with a reference to Obj_Id.
-
- ----------------------
- -- Replace_Type_Ref --
- ----------------------
-
- procedure Replace_Type_Ref (N : Node_Id) is
- Ref : Node_Id;
-
- begin
- -- Decorate the reference to Typ even though it may be rewritten
- -- further down. This is done for two reasons:
-
- -- 1) ASIS has all necessary semantic information in the
- -- original tree.
-
- -- 2) Routines which examine properties of the Original_Node
- -- have some semantic information.
-
- if Nkind (N) = N_Identifier then
- Set_Entity (N, Typ);
- Set_Etype (N, Typ);
-
- elsif Nkind (N) = N_Selected_Component then
- Analyze (Prefix (N));
- Set_Entity (Selector_Name (N), Typ);
- Set_Etype (Selector_Name (N), Typ);
- end if;
-
- -- Perform the following substitution:
-
- -- Typ --> _object
-
- Ref := Make_Identifier (Sloc (N), Chars (Obj_Id));
- Set_Entity (Ref, Obj_Id);
- Set_Etype (Ref, Typ);
-
- Rewrite (N, Ref);
-
- Set_Comes_From_Source (N, True);
- end Replace_Type_Ref;
-
- procedure Replace_Type_Refs is
- new Replace_Type_References_Generic (Replace_Type_Ref);
-
- -- Start of processing for Replace_Type_References
-
- begin
- Replace_Type_Refs (Expr, Typ);
- end Replace_Type_References;
-
-- Local variables
Loc : constant Source_Ptr := Sloc (Typ);
@@ -1740,6 +1527,9 @@
Proc_Id : Entity_Id;
Stmts : List_Id := No_List;
+ Build_Body : Boolean := False;
+ -- Flag set when the type requires a DIC procedure body to be built
+
Work_Typ : Entity_Id;
-- The working type
@@ -1854,9 +1644,18 @@
DIC_Typ => DIC_Typ,
Stmts => Stmts);
- -- Otherwise the working type inherits a DIC pragma from a parent type
+ Build_Body := True;
- else
+ -- Otherwise the working type inherits a DIC pragma from a parent type.
+ -- This processing is carried out when the type is frozen because the
+ -- state of all parent discriminants is known at that point. Note that
+ -- it is semantically sound to delay the creation of the DIC procedure
+ -- body till the freeze point. If the type has a DIC pragma of its own,
+ -- then the DIC procedure body would have already been constructed at
+ -- the end of the visible declarations and all parent DIC pragmas are
+ -- effectively "hidden" and irrelevant.
+
+ elsif For_Freeze then
pragma Assert (Has_Inherited_DIC (Work_Typ));
pragma Assert (DIC_Typ /= Work_Typ);
@@ -1882,66 +1681,71 @@
Deriv_Typ => Work_Typ,
Stmts => Stmts);
end if;
+
+ Build_Body := True;
end if;
End_Scope;
- -- Produce an empty completing body in the following cases:
- -- * Assertions are disabled
- -- * The DIC Assertion_Policy is Ignore
- -- * Pragma DIC appears without an argument
- -- * Pragma DIC appears with argument "null"
+ if Build_Body then
- if No (Stmts) then
- Stmts := New_List (Make_Null_Statement (Loc));
- end if;
+ -- Produce an empty completing body in the following cases:
+ -- * Assertions are disabled
+ -- * The DIC Assertion_Policy is Ignore
+ -- * Pragma DIC appears without an argument
+ -- * Pragma DIC appears with argument "null"
- -- Generate:
- -- procedure <Work_Typ>DIC (_object : <Work_Typ>) is
- -- begin
- -- <Stmts>
- -- end <Work_Typ>DIC;
+ if No (Stmts) then
+ Stmts := New_List (Make_Null_Statement (Loc));
+ end if;
- Proc_Body :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Copy_Subprogram_Spec (Parent (Proc_Id)),
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts));
- Proc_Body_Id := Defining_Entity (Proc_Body);
+ -- Generate:
+ -- procedure <Work_Typ>DIC (_object : <Work_Typ>) is
+ -- begin
+ -- <Stmts>
+ -- end <Work_Typ>DIC;
- -- Perform minor decoration in case the body is not analyzed
+ Proc_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Copy_Subprogram_Spec (Parent (Proc_Id)),
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts));
+ Proc_Body_Id := Defining_Entity (Proc_Body);
- Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
- Set_Etype (Proc_Body_Id, Standard_Void_Type);
- Set_Scope (Proc_Body_Id, Current_Scope);
+ -- Perform minor decoration in case the body is not analyzed
- -- Link both spec and body to avoid generating duplicates
+ Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
+ Set_Etype (Proc_Body_Id, Standard_Void_Type);
+ Set_Scope (Proc_Body_Id, Current_Scope);
- Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
- Set_Corresponding_Spec (Proc_Body, Proc_Id);
+ -- Link both spec and body to avoid generating duplicates
- -- The body should not be inserted into the tree when the context is
- -- ASIS or a generic unit because it is not part of the template. Note
- -- that the body must still be generated in order to resolve the DIC
- -- assertion expression.
+ Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
+ Set_Corresponding_Spec (Proc_Body, Proc_Id);
- if ASIS_Mode or Inside_A_Generic then
- null;
+ -- The body should not be inserted into the tree when the context
+ -- is ASIS or a generic unit because it is not part of the template.
+ -- Note that the body must still be generated in order to resolve the
+ -- DIC assertion expression.
- -- Semi-insert the body into the tree for GNATprove by setting its
- -- Parent field. This allows for proper upstream tree traversals.
+ if ASIS_Mode or Inside_A_Generic then
+ null;
- elsif GNATprove_Mode then
- Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
+ -- Semi-insert the body into the tree for GNATprove by setting its
+ -- Parent field. This allows for proper upstream tree traversals.
- -- Otherwise the body is part of the freezing actions of the working
- -- type.
+ elsif GNATprove_Mode then
+ Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
- else
- Append_Freeze_Action (Work_Typ, Proc_Body);
+ -- Otherwise the body is part of the freezing actions of the working
+ -- type.
+
+ else
+ Append_Freeze_Action (Work_Typ, Proc_Body);
+ end if;
end if;
<<Leave>>
@@ -3388,15 +3192,6 @@
end if;
end Ensure_Defined;
- -----------------
- -- Entity_Hash --
- -----------------
-
- function Entity_Hash (E : Entity_Id) return Num_Primitives is
- begin
- return Num_Primitives (E mod Primitives_Mapping_Size);
- end Entity_Hash;
-
--------------------
-- Entry_Names_OK --
--------------------
@@ -8289,6 +8084,585 @@
Constraints => List_Constr));
end Make_Subtype_From_Expr;
+ ---------------
+ -- Map_Types --
+ ---------------
+
+ procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id) is
+
+ -- NOTE: Most of the routines in Map_Types are intentionally unnested to
+ -- avoid deep indentation of code.
+
+ -- NOTE: Routines which deal with discriminant mapping operate on the
+ -- [underlying/record] full view of various types because those views
+ -- contain all discriminants and stored constraints.
+
+ procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id);
+ -- Subsidiary to Map_Primitives. Find a primitive in the inheritance or
+ -- overriding chain starting from Prim whose dispatching type is parent
+ -- type Par_Typ and add a mapping between the result and primitive Prim.
+
+ function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id;
+ -- Subsidiary to Map_Primitives. Return the next ancestor primitive in
+ -- the inheritance or overriding chain of subprogram Subp. Return Empty
+ -- if no such primitive is available.
+
+ function Build_Chain
+ (Par_Typ : Entity_Id;
+ Deriv_Typ : Entity_Id) return Elist_Id;
+ -- Subsidiary to Map_Discriminants. Recreate the derivation chain from
+ -- parent type Par_Typ leading down towards derived type Deriv_Typ. The
+ -- list has the form:
+ --
+ -- head tail
+ -- v v
+ -- <Ancestor_N> -> <Ancestor_N-1> -> <Ancestor_1> -> Deriv_Typ
+ --
+ -- Note that Par_Typ is not part of the resulting derivation chain
+
+ function Discriminated_View (Typ : Entity_Id) return Entity_Id;
+ -- Return the view of type Typ which could potentially contains either
+ -- the discriminants or stored constraints of the type.
+
+ function Find_Discriminant_Value
+ (Discr : Entity_Id;
+ Par_Typ : Entity_Id;
+ Deriv_Typ : Entity_Id;
+ Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id;
+ -- Subsidiary to Map_Discriminants. Find the value of discriminant Discr
+ -- in the derivation chain starting from parent type Par_Typ leading to
+ -- derived type Deriv_Typ. The returned value is one of the following:
+ --
+ -- * An entity which is either a discriminant or a non-discriminant
+ -- name, and renames/constraints Discr.
+ --
+ -- * An expression which constraints Discr
+ --
+ -- Typ_Elmt is an element of the derivation chain created by routine
+ -- Build_Chain and denotes the current ancestor being examined.
+
+ procedure Map_Discriminants
+ (Par_Typ : Entity_Id;
+ Deriv_Typ : Entity_Id);
+ -- Map each discriminant of type Par_Typ to a meaningful constraint
+ -- from the point of view of type Deriv_Typ.
+
+ procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id);
+ -- Map each primitive of type Par_Typ to a corresponding primitive of
+ -- type Deriv_Typ.
+
+ -------------------
+ -- Add_Primitive --
+ -------------------
+
+ procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id) is
+ Par_Prim : Entity_Id;
+
+ begin
+ -- Inspect the inheritance chain through the Alias attribute and the
+ -- overriding chain through the Overridden_Operation looking for an
+ -- ancestor primitive with the appropriate dispatching type.
+
+ Par_Prim := Prim;
+ while Present (Par_Prim) loop
+ exit when Find_Dispatching_Type (Par_Prim) = Par_Typ;
+ Par_Prim := Ancestor_Primitive (Par_Prim);
+ end loop;
+
+ -- Create a mapping of the form:
+
+ -- parent type primitive -> derived type primitive
+
+ if Present (Par_Prim) then
+ Type_Map.Set (Par_Prim, Prim);
+ end if;
+ end Add_Primitive;
+
+ ------------------------
+ -- Ancestor_Primitive --
+ ------------------------
+
+ function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is
+ Inher_Prim : constant Entity_Id := Alias (Subp);
+ Over_Prim : constant Entity_Id := Overridden_Operation (Subp);
+
+ begin
+ -- The current subprogram overrides an ancestor primitive
+
+ if Present (Over_Prim) then
+ return Over_Prim;
+
+ -- The current subprogram is an internally generated alias of an
+ -- inherited ancestor primitive.
+
+ elsif Present (Inher_Prim) then
+ return Inher_Prim;
+
+ -- Otherwise the current subprogram is the root of the inheritance or
+ -- overriding chain.
+
+ else
+ return Empty;
+ end if;
+ end Ancestor_Primitive;
+
+ -----------------
+ -- Build_Chain --
+ -----------------
+
+ function Build_Chain
+ (Par_Typ : Entity_Id;
+ Deriv_Typ : Entity_Id) return Elist_Id
+ is
+ Anc_Typ : Entity_Id;
+ Chain : Elist_Id;
+ Curr_Typ : Entity_Id;
+
+ begin
+ Chain := New_Elmt_List;
+
+ -- Add the derived type to the derivation chain
+
+ Prepend_Elmt (Deriv_Typ, Chain);
+
+ -- Examine all ancestors starting from the derived type climbing
+ -- towards parent type Par_Typ.
+
+ Curr_Typ := Deriv_Typ;
+ loop
+ -- Work with the view which contains the discriminants and stored
+ -- constraints.
+
+ Anc_Typ := Discriminated_View (Base_Type (Etype (Curr_Typ)));
+
+ -- Use the first subtype when dealing with base types
+
+ if Is_Itype (Anc_Typ) then
+ Anc_Typ := First_Subtype (Anc_Typ);
+ end if;
+
+ -- Stop the climb when either the parent type has been reached or
+ -- there are no more ancestors left to examine.
+
+ exit when Anc_Typ = Curr_Typ or else Anc_Typ = Par_Typ;
+
+ Prepend_Unique_Elmt (Anc_Typ, Chain);
+ Curr_Typ := Anc_Typ;
+ end loop;
+
+ return Chain;
+ end Build_Chain;
+
+ ------------------------
+ -- Discriminated_View --
+ ------------------------
+
+ function Discriminated_View (Typ : Entity_Id) return Entity_Id is
+ T : Entity_Id;
+
+ begin
+ T := Typ;
+
+ -- Use the [underlying] full view when dealing with private types
+ -- because the view contains all inherited discriminants or stored
+ -- constraints.
+
+ if Is_Private_Type (T) then
+ if Present (Underlying_Full_View (T)) then
+ T := Underlying_Full_View (T);
+
+ elsif Present (Full_View (T)) then
+ T := Full_View (T);
+ end if;
+ end if;
+
+ -- Use the underlying record view when the type is an extenstion of
+ -- a parent type with unknown discriminants because the view contains
+ -- all inherited discriminants or stored constraints.
+
+ if Ekind (T) = E_Record_Type
+ and then Present (Underlying_Record_View (T))
+ then
+ T := Underlying_Record_View (T);
+ end if;
+
+ return T;
+ end Discriminated_View;
+
+ -----------------------------
+ -- Find_Discriminant_Value --
+ -----------------------------
+
+ function Find_Discriminant_Value
+ (Discr : Entity_Id;
+ Par_Typ : Entity_Id;
+ Deriv_Typ : Entity_Id;
+ Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id
+ is
+ Discr_Pos : constant Uint := Discriminant_Number (Discr);
+ Typ : constant Entity_Id := Node (Typ_Elmt);
+
+ function Find_Constraint_Value
+ (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id;
+ -- Given constraint Constr, find what it denotes. This is either:
+ --
+ -- * An entity which is either a discriminant or a name
+ --
+ -- * An expression
+
+ ---------------------------
+ -- Find_Constraint_Value --
+ ---------------------------
+
+ function Find_Constraint_Value
+ (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id
+ is
+ begin
+ if Nkind (Constr) in N_Entity then
+
+ -- The constraint denotes a discriminant of the curren type
+ -- which renames the ancestor discriminant:
+
+ -- vv
+ -- type Typ (D1 : ...; DN : ...) is
+ -- new Anc (Discr => D1) with ...
+ -- ^^
+
+ if Ekind (Constr) = E_Discriminant then
+
+ -- The discriminant belongs to derived type Deriv_Typ. This
+ -- is the final value for the ancestor discriminant as the
+ -- derivations chain has been fully exhausted.
+
+ if Typ = Deriv_Typ then
+ return Constr;
+
+ -- Otherwise the discriminant may be renamed or constrained
+ -- at a lower level. Continue looking down the derivation
+ -- chain.
+
+ else
+ return
+ Find_Discriminant_Value
+ (Discr => Constr,
+ Par_Typ => Par_Typ,
+ Deriv_Typ => Deriv_Typ,
+ Typ_Elmt => Next_Elmt (Typ_Elmt));
+ end if;
+
+ -- Otherwise the constraint denotes a reference to some name
+ -- which results in a Girder discriminant:
+
+ -- vvvv
+ -- Name : ...;
+ -- type Typ (D1 : ...; DN : ...) is
+ -- new Anc (Discr => Name) with ...
+ -- ^^^^
+
+ -- Return the name as this is the proper constraint of the
+ -- discriminant.
+
+ else
+ return Constr;
+ end if;
+
+ -- The constraint denotes a reference to a name
+
+ elsif Is_Entity_Name (Constr) then
+ return Find_Constraint_Value (Entity (Constr));
+
+ -- Otherwise the current constraint is an expression which yields
+ -- a Girder discriminant:
+
+ -- type Typ (D1 : ...; DN : ...) is
+ -- new Anc (Discr => <expression>) with ...
+ -- ^^^^^^^^^^
+
+ -- Return the expression as this is the proper constraint of the
+ -- discriminant.
+
+ else
+ return Constr;
+ end if;
+ end Find_Constraint_Value;
+
+ -- Local variables
+
+ Constrs : constant Elist_Id := Stored_Constraint (Typ);
+
+ Constr_Elmt : Elmt_Id;
+ Pos : Uint;
+ Typ_Discr : Entity_Id;
+
+ -- Start of processing for Find_Discriminant_Value
+
+ begin
+ -- The algorithm for finding the value of a discriminant works as
+ -- follows. First, it recreates the derivation chain from Par_Typ
+ -- to Deriv_Typ as a list:
+
+ -- Par_Typ (shown for completeness)
+ -- v
+ -- Ancestor_N <-- head of chain
+ -- v
+ -- Ancestor_1
+ -- v
+ -- Deriv_Typ <-- tail of chain
+
+ -- The algorithm then traces the fate of a parent discriminant down
+ -- the derivation chain. At each derivation level, the discriminant
+ -- may be either inherited or constrained.
+
+ -- 1) Discriminant is inherited: there are two cases, depending on
+ -- which type is inheriting.
+
+ -- 1.1) Deriv_Typ is inheriting:
+
+ -- type Ancestor (D_1 : ...) is tagged ...
+ -- type Deriv_Typ is new Ancestor ...
+
+ -- In this case the inherited discriminant is the final value of
+ -- the parent discriminant because the end of the derivation chain
+ -- has been reached.
+
+ -- 1.2) Some other type is inheriting:
+
+ -- type Ancestor_1 (D_1 : ...) is tagged ...
+ -- type Ancestor_2 is new Ancestor_1 ...
+
+ -- In this case the algorithm continues to trace the fate of the
+ -- inherited discriminant down the derivation chain because it may
+ -- be further inherited or constrained.
+
+ -- 2) Discriminant is constrained: there are three cases, depending
+ -- on what the constraint is.
+
+ -- 2.1) The constraint is another discriminant (aka renaming):
+
+ -- type Ancestor_1 (D_1 : ...) is tagged ...
+ -- type Ancestor_2 (D_2 : ...) is new Ancestor_1 (D_1 => D_2) ...
+
+ -- In this case the constraining discriminant becomes the one to
+ -- track down the derivation chain. The algorithm already knows
+ -- that D_2 constrains D_1, therefore if the algorithm finds the
+ -- value of D_2, then this would also be the value for D_1.
+
+ -- 2.2) The constraint is a name (aka Girder):
+
+ -- Name : ...
+ -- type Ancestor_1 (D_1 : ...) is tagged ...
+ -- type Ancestor_2 is new Ancestor_1 (D_1 => Name) ...
+
+ -- In this case the name is the final value of D_1 because the
+ -- discriminant cannot be further constrained.
+
+ -- 2.3) The constraint is an expression (aka Girder):
+
+ -- type Ancestor_1 (D_1 : ...) is tagged ...
+ -- type Ancestor_2 is new Ancestor_1 (D_1 => 1 + 2) ...
+
+ -- Similar to 2.2, the expression is the final value of D_1
+
+ Pos := Uint_1;
+
+ -- When a derived type constrains its parent type, all constaints
+ -- appear in the Stored_Constraint list. Examine the list looking
+ -- for a positional match.
+
+ if Present (Constrs) then
+ Constr_Elmt := First_Elmt (Constrs);
+ while Present (Constr_Elmt) loop
+
+ -- The position of the current constraint matches that of the
+ -- ancestor discriminant.
+
+ if Pos = Discr_Pos then
+ return Find_Constraint_Value (Node (Constr_Elmt));
+ end if;
+
+ Next_Elmt (Constr_Elmt);
+ Pos := Pos + 1;
+ end loop;
+
+ -- Otherwise the derived type does not constraint its parent type in
+ -- which case it inherits the parent discriminants.
+
+ else
+ Typ_Discr := First_Discriminant (Typ);
+ while Present (Typ_Discr) loop
+
+ -- The position of the current discriminant matches that of the
+ -- ancestor discriminant.
+
+ if Pos = Discr_Pos then
+ return Find_Constraint_Value (Typ_Discr);
+ end if;
+
+ Next_Discriminant (Typ_Discr);
+ Pos := Pos + 1;
+ end loop;
+ end if;
+
+ -- A discriminant must always have a corresponding value. This is
+ -- either another discriminant, a name, or an expression. If this
+ -- point is reached, them most likely the derivation chain employs
+ -- the wrong views of types.
+
+ pragma Assert (False);
+
+ return Empty;
+ end Find_Discriminant_Value;
+
+ -----------------------
+ -- Map_Discriminants --
+ -----------------------
+
+ procedure Map_Discriminants
+ (Par_Typ : Entity_Id;
+ Deriv_Typ : Entity_Id)
+ is
+ Deriv_Chain : constant Elist_Id := Build_Chain (Par_Typ, Deriv_Typ);
+
+ Discr : Entity_Id;
+ Discr_Val : Node_Or_Entity_Id;
+
+ begin
+ -- Examine each discriminant of parent type Par_Typ and find a
+ -- suitable value for it from the point of view of derived type
+ -- Deriv_Typ.
+
+ if Has_Discriminants (Par_Typ) then
+ Discr := First_Discriminant (Par_Typ);
+ while Present (Discr) loop
+ Discr_Val :=
+ Find_Discriminant_Value
+ (Discr => Discr,
+ Par_Typ => Par_Typ,
+ Deriv_Typ => Deriv_Typ,
+ Typ_Elmt => First_Elmt (Deriv_Chain));
+
+ -- Create a mapping of the form:
+
+ -- parent type discriminant -> value
+
+ Type_Map.Set (Discr, Discr_Val);
+
+ Next_Discriminant (Discr);
+ end loop;
+ end if;
+ end Map_Discriminants;
+
+ --------------------
+ -- Map_Primitives --
+ --------------------
+
+ procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id) is
+ Deriv_Prim : Entity_Id;
+ Par_Prim : Entity_Id;
+ Par_Prims : Elist_Id;
+ Prim_Elmt : Elmt_Id;
+
+ begin
+ -- Inspect the primitives of the derived type and determine whether
+ -- they relate to the primitives of the parent type. If there is a
+ -- meaningful relation, create a mapping of the form:
+
+ -- parent type primitive -> perived type primitive
+
+ if Present (Direct_Primitive_Operations (Deriv_Typ)) then
+ Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ));
+ while Present (Prim_Elmt) loop
+ Deriv_Prim := Node (Prim_Elmt);
+
+ if Is_Subprogram (Deriv_Prim)
+ and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ
+ then
+ Add_Primitive (Deriv_Prim, Par_Typ);
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end if;
+
+ -- If the parent operation is an interface operation, the overriding
+ -- indicator is not present. Instead, we get from the interface
+ -- operation the primitive of the current type that implements it.
+
+ if Is_Interface (Par_Typ) then
+ Par_Prims := Collect_Primitive_Operations (Par_Typ);
+
+ if Present (Par_Prims) then
+ Prim_Elmt := First_Elmt (Par_Prims);
+
+ while Present (Prim_Elmt) loop
+ Par_Prim := Node (Prim_Elmt);
+ Deriv_Prim :=
+ Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim);
+
+ if Present (Deriv_Prim) then
+ Type_Map.Set (Par_Prim, Deriv_Prim);
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end if;
+ end if;
+ end Map_Primitives;
+
+ -- Start of processing for Map_Types
+
+ begin
+ -- Nothing to do if there are no types to work with
+
+ if No (Parent_Type) or else No (Derived_Type) then
+ return;
+
+ -- Nothing to do if the mapping already exists
+
+ elsif Type_Map.Get (Parent_Type) = Derived_Type then
+ return;
+
+ -- Nothing to do if both types are not tagged. Note that untagged types
+ -- do not have primitive operations and their discriminants are already
+ -- handled by gigi.
+
+ elsif not Is_Tagged_Type (Parent_Type)
+ or else not Is_Tagged_Type (Derived_Type)
+ then
+ return;
+ end if;
+
+ -- Create a mapping of the form
+
+ -- parent type -> derived type
+
+ -- to prevent any subsequent attempts to produce the same relations
+
+ Type_Map.Set (Parent_Type, Derived_Type);
+
+ -- Create mappings of the form
+
+ -- parent type discriminant -> derived type discriminant
+ -- <or>
+ -- parent type discriminant -> constraint
+
+ -- Note that mapping of discriminants breaks privacy because it needs to
+ -- work with those views which contains the discriminants and any stored
+ -- constraints.
+
+ Map_Discriminants
+ (Par_Typ => Discriminated_View (Parent_Type),
+ Deriv_Typ => Discriminated_View (Derived_Type));
+
+ -- Create mappings of the form
+
+ -- parent type primitive -> derived type primitive
+
+ Map_Primitives
+ (Par_Typ => Parent_Type,
+ Deriv_Typ => Derived_Type);
+ end Map_Types;
+
----------------------------
-- Matching_Standard_Type --
----------------------------
@@ -9521,6 +9895,321 @@
Scope_Suppress := Svg_Suppress;
end Remove_Side_Effects;
+ ------------------------
+ -- Replace_References --
+ ------------------------
+
+ procedure Replace_References
+ (Expr : Node_Id;
+ Par_Typ : Entity_Id;
+ Deriv_Typ : Entity_Id;
+ Par_Obj : Entity_Id := Empty;
+ Deriv_Obj : Entity_Id := Empty)
+ is
+ function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean;
+ -- Determine whether node Ref denotes some component of Deriv_Obj
+
+ function Replace_Ref (Ref : Node_Id) return Traverse_Result;
+ -- Substitute a reference to an entity with the corresponding value
+ -- stored in table Type_Map.
+
+ function Type_Of_Formal
+ (Call : Node_Id;
+ Actual : Node_Id) return Entity_Id;
+ -- Find the type of the formal parameter which corresponds to actual
+ -- parameter Actual in subprogram call Call.
+
+ ----------------------
+ -- Is_Deriv_Obj_Ref --
+ ----------------------
+
+ function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean is
+ Par : constant Node_Id := Parent (Ref);
+
+ begin
+ -- Detect the folowing selected component form:
+
+ -- Deriv_Obj.(something)
+
+ return
+ Nkind (Par) = N_Selected_Component
+ and then Is_Entity_Name (Prefix (Par))
+ and then Entity (Prefix (Par)) = Deriv_Obj;
+ end Is_Deriv_Obj_Ref;
+
+ -----------------
+ -- Replace_Ref --
+ -----------------
+
+ function Replace_Ref (Ref : Node_Id) return Traverse_Result is
+ Context : constant Node_Id := Parent (Ref);
+ Loc : constant Source_Ptr := Sloc (Ref);
+ Ref_Id : Entity_Id;
+ Result : Traverse_Result;
+
+ New_Ref : Node_Id;
+ -- The new reference which is intended to substitute the old one
+
+ Old_Ref : Node_Id;
+ -- The reference designated for replacement. In certain cases this
+ -- may be a node other than Ref.
+
+ Val : Node_Or_Entity_Id;
+ -- The corresponding value of Ref from the type map
+
+ begin
+ -- Assume that the input reference is to be replaced and that the
+ -- traversal should examine the children of the reference.
+
+ Old_Ref := Ref;
+ Result := OK;
+
+ -- The input denotes a meaningful reference
+
+ if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then
+ Ref_Id := Entity (Ref);
+ Val := Type_Map.Get (Ref_Id);
+
+ -- The reference has a corresponding value in the type map, a
+ -- substitution is possible.
+
+ if Present (Val) then
+
+ -- The reference denotes a discriminant
+
+ if Ekind (Ref_Id) = E_Discriminant then
+ if Nkind (Val) in N_Entity then
+
+ -- The value denotes another discriminant. Replace as
+ -- follows:
+
+ -- _object.Discr -> _object.Val
+
+ if Ekind (Val) = E_Discriminant then
+ New_Ref := New_Occurrence_Of (Val, Loc);
+
+ -- Otherwise the value denotes the entity of a name which
+ -- constraints the discriminant. Replace as follows:
+
+ -- _object.Discr -> Val
+
+ else
+ pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
+
+ New_Ref := New_Occurrence_Of (Val, Loc);
+ Old_Ref := Parent (Old_Ref);
+ end if;
+
+ -- Otherwise the value denotes an arbitrary expression which
+ -- constraints the discriminant. Replace as follows:
+
+ -- _object.Discr -> Val
+
+ else
+ pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
+
+ New_Ref := New_Copy_Tree (Val);
+ Old_Ref := Parent (Old_Ref);
+ end if;
+
+ -- Otherwise the reference denotes a primitive. Replace as
+ -- follows:
+
+ -- Primitive -> Val
+
+ else
+ pragma Assert (Nkind (Val) in N_Entity);
+ New_Ref := New_Occurrence_Of (Val, Loc);
+ end if;
+
+ -- The reference mentions the _object parameter of the parent
+ -- type's DIC procedure. Replace as follows:
+
+ -- _object -> _object
+
+ elsif Present (Par_Obj)
+ and then Present (Deriv_Obj)
+ and then Ref_Id = Par_Obj
+ then
+ New_Ref := New_Occurrence_Of (Deriv_Obj, Loc);
+
+ -- The reference to _object acts as an actual parameter in a
+ -- subprogram call which may be invoking a primitive of the
+ -- parent type:
+
+ -- Primitive (... _object ...);
+
+ -- The parent type primitive may not be overridden nor
+ -- inherited when it is declared after the derived type
+ -- definition:
+
+ -- type Parent is tagged private;
+ -- type Child is new Parent with private;
+ -- procedure Primitive (Obj : Parent);
+
+ -- In this scenario the _object parameter is converted to the
+ -- parent type. Due to complications with partial/full views
+ -- and view swaps, the parent type is taken from the formal
+ -- parameter of the subprogram being called.
+
+ if Nkind_In (Context, N_Function_Call,
+ N_Procedure_Call_Statement)
+ and then No (Type_Map.Get (Entity (Name (Context))))
+ then
+ New_Ref :=
+ Convert_To (Type_Of_Formal (Context, Old_Ref), New_Ref);
+
+ -- Do not process the generated type conversion because
+ -- both the parent type and the derived type are in the
+ -- Type_Map table. This will clobber the type conversion
+ -- by resetting its subtype mark.
+
+ Result := Skip;
+ end if;
+
+ -- Otherwise there is nothing to replace
+
+ else
+ New_Ref := Empty;
+ end if;
+
+ if Present (New_Ref) then
+ Rewrite (Old_Ref, New_Ref);
+
+ -- Update the return type when the context of the reference
+ -- acts as the name of a function call. Note that the update
+ -- should not be performed when the reference appears as an
+ -- actual in the call.
+
+ if Nkind (Context) = N_Function_Call
+ and then Name (Context) = Old_Ref
+ then
+ Set_Etype (Context, Etype (Val));
+ end if;
+ end if;
+ end if;
+
+ -- Reanalyze the reference due to potential replacements
+
+ if Nkind (Old_Ref) in N_Has_Etype then
+ Set_Analyzed (Old_Ref, False);
+ end if;
+
+ return Result;
+ end Replace_Ref;
+
+ procedure Replace_Refs is new Traverse_Proc (Replace_Ref);
+
+ --------------------
+ -- Type_Of_Formal --
+ --------------------
+
+ function Type_Of_Formal
+ (Call : Node_Id;
+ Actual : Node_Id) return Entity_Id
+ is
+ A : Node_Id;
+ F : Entity_Id;
+
+ begin
+ -- Examine the list of actual and formal parameters in parallel
+
+ A := First (Parameter_Associations (Call));
+ F := First_Formal (Entity (Name (Call)));
+ while Present (A) and then Present (F) loop
+ if A = Actual then
+ return Etype (F);
+ end if;
+
+ Next (A);
+ Next_Formal (F);
+ end loop;
+
+ -- The actual parameter must always have a corresponding formal
+
+ pragma Assert (False);
+
+ return Empty;
+ end Type_Of_Formal;
+
+ -- Start of processing for Replace_References
+
+ begin
+ -- Map the attributes of the parent type to the proper corresponding
+ -- attributes of the derived type.
+
+ Map_Types
+ (Parent_Type => Par_Typ,
+ Derived_Type => Deriv_Typ);
+
+ -- Inspect the input expression and perform substitutions where
+ -- necessary.
+
+ Replace_Refs (Expr);
+ end Replace_References;
+
+ -----------------------------
+ -- Replace_Type_References --
+ -----------------------------
+
+ procedure Replace_Type_References
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Obj_Id : Entity_Id)
+ is
+ procedure Replace_Type_Ref (N : Node_Id);
+ -- Substitute a single reference of the current instance of type Typ
+ -- with a reference to Obj_Id.
+
+ ----------------------
+ -- Replace_Type_Ref --
+ ----------------------
+
+ procedure Replace_Type_Ref (N : Node_Id) is
+ Ref : Node_Id;
+
+ begin
+ -- Decorate the reference to Typ even though it may be rewritten
+ -- further down. This is done for two reasons:
+
+ -- * ASIS has all necessary semantic information in the original
+ -- tree.
+
+ -- * Routines which examine properties of the Original_Node have
+ -- some semantic information.
+
+ if Nkind (N) = N_Identifier then
+ Set_Entity (N, Typ);
+ Set_Etype (N, Typ);
+
+ elsif Nkind (N) = N_Selected_Component then
+ Analyze (Prefix (N));
+ Set_Entity (Selector_Name (N), Typ);
+ Set_Etype (Selector_Name (N), Typ);
+ end if;
+
+ -- Perform the following substitution:
+
+ -- Typ -> _object
+
+ Ref := Make_Identifier (Sloc (N), Chars (Obj_Id));
+ Set_Entity (Ref, Obj_Id);
+ Set_Etype (Ref, Typ);
+
+ Rewrite (N, Ref);
+
+ Set_Comes_From_Source (N, True);
+ end Replace_Type_Ref;
+
+ procedure Replace_Type_Refs is
+ new Replace_Type_References_Generic (Replace_Type_Ref);
+
+ -- Start of processing for Replace_Type_References
+
+ begin
+ Replace_Type_Refs (Expr, Typ);
+ end Replace_Type_References;
+
---------------------------
-- Represented_As_Scalar --
---------------------------
@@ -10964,6 +11653,15 @@
and then Esize (Left_Typ) = Esize (Result_Typ);
end Target_Has_Fixed_Ops;
+ -------------------
+ -- Type_Map_Hash --
+ -------------------
+
+ function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header is
+ begin
+ return Type_Map_Header (Id mod Type_Map_Size);
+ end Type_Map_Hash;
+
------------------------------------------
-- Type_May_Have_Bit_Aligned_Components --
------------------------------------------
@@ -11015,163 +11713,11 @@
Subp_Id : Entity_Id)
is
begin
- Update_Primitives_Mapping_Of_Types
- (Par_Typ => Find_Dispatching_Type (Inher_Id),
- Deriv_Typ => Find_Dispatching_Type (Subp_Id));
+ Map_Types
+ (Parent_Type => Find_Dispatching_Type (Inher_Id),
+ Derived_Type => Find_Dispatching_Type (Subp_Id));
end Update_Primitives_Mapping;
- ----------------------------------------
- -- Update_Primitives_Mapping_Of_Types --
- ----------------------------------------
-
- procedure Update_Primitives_Mapping_Of_Types
- (Par_Typ : Entity_Id;
- Deriv_Typ : Entity_Id)
- is
- procedure Add_Primitive (Prim : Entity_Id);
- -- Find a primitive in the inheritance/overriding chain starting from
- -- Prim whose dispatching type is parent type Par_Typ and add a mapping
- -- between the result and primitive Prim.
-
- -------------------
- -- Add_Primitive --
- -------------------
-
- procedure Add_Primitive (Prim : Entity_Id) is
- function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id;
- -- Return the next ancestor primitive in the inheritance/overriding
- -- chain of subprogram Subp. Return Empty if no such primitive is
- -- available.
-
- ------------------------
- -- Ancestor_Primitive --
- ------------------------
-
- function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is
- Inher_Prim : constant Entity_Id := Alias (Subp);
- Over_Prim : constant Entity_Id := Overridden_Operation (Subp);
-
- begin
- -- The current subprogram overrides an ancestor primitive
-
- if Present (Over_Prim) then
- return Over_Prim;
-
- -- The current subprogram is an internally generated alias of an
- -- inherited ancestor primitive.
-
- elsif Present (Inher_Prim) then
- return Inher_Prim;
-
- -- Otherwise the current subprogram is the root of the inheritance
- -- or overriding chain.
-
- else
- return Empty;
- end if;
- end Ancestor_Primitive;
-
- -- Local variables
-
- Par_Prim : Entity_Id;
-
- -- Start of processing for Add_Primitive
-
- begin
- -- Inspect both the inheritance chain through the Alias attribute and
- -- the overriding chain through the Overridden_Operation looking for
- -- an ancestor primitive with the appropriate dispatching type.
-
- Par_Prim := Prim;
- while Present (Par_Prim) loop
- exit when Find_Dispatching_Type (Par_Prim) = Par_Typ;
- Par_Prim := Ancestor_Primitive (Par_Prim);
- end loop;
-
- -- Create a mapping of the form:
-
- -- Parent type primitive -> derived type primitive
-
- if Present (Par_Prim) then
- Primitives_Mapping.Set (Par_Prim, Prim);
- end if;
- end Add_Primitive;
-
- -- Local variables
-
- Deriv_Prim : Entity_Id;
- Par_Prim : Entity_Id;
- Par_Prims : Elist_Id;
- Prim_Elmt : Elmt_Id;
-
- -- Start of processing for Update_Primitives_Mapping_Of_Types
-
- begin
- -- Nothing to do if there are no types to work with
-
- if No (Par_Typ) or else No (Deriv_Typ) then
- return;
-
- -- Nothing to do if the mapping already exists
-
- elsif Primitives_Mapping.Get (Par_Typ) = Deriv_Typ then
- return;
- end if;
-
- -- Create a mapping of the form:
-
- -- Parent type -> Derived type
-
- -- to prevent any subsequent attempts to produce the same relations.
-
- Primitives_Mapping.Set (Par_Typ, Deriv_Typ);
-
- -- Inspect the primitives of the derived type and determine whether they
- -- relate to the primitives of the parent type. If there is a meaningful
- -- relation, create a mapping of the form:
-
- -- Parent type primitive -> Derived type primitive
-
- if Present (Direct_Primitive_Operations (Deriv_Typ)) then
- Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ));
- while Present (Prim_Elmt) loop
- Deriv_Prim := Node (Prim_Elmt);
-
- if Is_Subprogram (Deriv_Prim)
- and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ
- then
- Add_Primitive (Deriv_Prim);
- end if;
-
- Next_Elmt (Prim_Elmt);
- end loop;
- end if;
-
- -- If the parent operation is an interface operation, the overriding
- -- indicator is not present. Instead, we get from the interface
- -- operation the primitive of the current type that implements it.
-
- if Is_Interface (Par_Typ) then
- Par_Prims := Collect_Primitive_Operations (Par_Typ);
-
- if Present (Par_Prims) then
- Prim_Elmt := First_Elmt (Par_Prims);
-
- while Present (Prim_Elmt) loop
- Par_Prim := Node (Prim_Elmt);
- Deriv_Prim :=
- Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim);
-
- if Present (Deriv_Prim) then
- Primitives_Mapping.Set (Par_Prim, Deriv_Prim);
- end if;
-
- Next_Elmt (Prim_Elmt);
- end loop;
- end if;
- end if;
- end Update_Primitives_Mapping_Of_Types;
-
----------------------------------
-- Within_Case_Or_If_Expression --
----------------------------------
Index: exp_util.ads
===================================================================
--- exp_util.ads (revision 247143)
+++ exp_util.ads (working copy)
@@ -278,9 +278,13 @@
-- Build a call to the DIC procedure of type Typ with Obj_Id as the actual
-- parameter.
- procedure Build_DIC_Procedure_Body (Typ : Entity_Id);
+ procedure Build_DIC_Procedure_Body
+ (Typ : Entity_Id;
+ For_Freeze : Boolean := False);
-- Create the body of the procedure which verifies the assertion expression
- -- of pragma Default_Initial_Condition at run time.
+ -- of pragma Default_Initial_Condition at run time. Flag For_Freeze should
+ -- be set when the body is construction as part of the freezing actions for
+ -- Typ.
procedure Build_DIC_Procedure_Declaration (Typ : Entity_Id);
-- Create the declaration of the procedure which verifies the assertion
@@ -870,6 +874,19 @@
-- wide type. Set Related_Id to request an external name for the subtype
-- rather than an internal temporary.
+ procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id);
+ -- Establish the following mapping between the attributes of tagged parent
+ -- type Parent_Type and tagged derived type Derived_Type.
+ --
+ -- * Map each discriminant of Parent_Type to ether the corresponding
+ -- discriminant of Derived_Type or come constraint.
+
+ -- * Map each primitive operation of Parent_Type to the corresponding
+ -- primitive of Derived_Type.
+ --
+ -- The mapping Parent_Type -> Derived_Type is also added to the table in
+ -- order to prevent subsequent attempts of the same mapping.
+
function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id;
-- Given a scalar subtype Typ, returns a matching type in standard that
-- has the same object size value. For example, a 16 bit signed type will
@@ -995,6 +1012,37 @@
-- renaming cannot be elaborated without evaluating the subexpression, so
-- gigi would resort to method 1) or 3) under the hood for them.
+ procedure Replace_References
+ (Expr : Node_Id;
+ Par_Typ : Entity_Id;
+ Deriv_Typ : Entity_Id;
+ Par_Obj : Entity_Id := Empty;
+ Deriv_Obj : Entity_Id := Empty);
+ -- Expr denotes an arbitrary expression. Par_Typ is a tagged parent type
+ -- in a type hierarchy. Deriv_Typ is a tagged type derived from Par_Typ
+ -- with optional ancestors in between. Par_Obj is a formal parameter
+ -- which emulates the current instance of Par_Typ. Deriv_Obj is a formal
+ -- parameter which emulates the current instance of Deriv_Typ. Perform the
+ -- following substitutions in Expr:
+ --
+ -- * Replace a reference to Par_Obj with a reference to Deriv_Obj
+ --
+ -- * Replace a reference to a discriminant of Par_Typ with a suitable
+ -- value from the point of view of Deriv_Typ.
+ --
+ -- * Replace a call to an overridden primitive of Par_Typ with a call to
+ -- an overriding primitive of Deriv_Typ.
+ --
+ -- * Replace a call to an inherited primitive of Par_Type with a call to
+ -- the internally-generated inherited primitive of Deriv_Typ.
+
+ procedure Replace_Type_References
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Obj_Id : Entity_Id);
+ -- Substitute all references of the current instance of type Typ with
+ -- references to formal parameter Obj_Id within expression Expr.
+
function Represented_As_Scalar (T : Entity_Id) return Boolean;
-- Returns True iff the implementation of this type in code generation
-- terms is scalar. This is true for scalars in the Ada sense, and for
@@ -1103,12 +1151,6 @@
-- when elaborating a contract for a subprogram, and when freezing a type
-- extension to verify legality rules on inherited conditions.
- procedure Update_Primitives_Mapping_Of_Types
- (Par_Typ : Entity_Id;
- Deriv_Typ : Entity_Id);
- -- Map the primitive operations of parent type Par_Typ to the corresponding
- -- primitives of derived type Deriv_Typ.
-
function Within_Case_Or_If_Expression (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N is within a case or an if expression
Index: sem_ch7.adb
===================================================================
--- sem_ch7.adb (revision 247143)
+++ sem_ch7.adb (working copy)
@@ -2568,6 +2568,11 @@
Propagate_DIC_Attributes (Full, From_Typ => Full_Base);
Propagate_DIC_Attributes (Full_Base, From_Typ => Full);
+ -- Propagate Default_Initial_Condition-related attributes from the
+ -- full view to the private view.
+
+ Propagate_DIC_Attributes (Priv, From_Typ => Full);
+
-- Propagate invariant-related attributes from the base type of the
-- full view to the full view and vice versa. This may seem strange,
-- but is necessary depending on which type triggered the generation
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 247147)
+++ sem_prag.adb (working copy)
@@ -13839,6 +13839,7 @@
Check_No_Identifiers;
Check_At_Most_N_Arguments (1);
+ Typ := Empty;
Stmt := Prev (N);
while Present (Stmt) loop
@@ -13880,6 +13881,14 @@
Stmt := Prev (Stmt);
end loop;
+ -- The pragma does not apply to a legal construct, issue an error
+ -- and stop the analysis.
+
+ if No (Typ) then
+ Pragma_Misplaced;
+ return;
+ end if;
+
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
Index: elists.adb
===================================================================
--- elists.adb (revision 247135)
+++ elists.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
@@ -450,6 +450,17 @@
Elists.Table (To).First := Elmts.Last;
end Prepend_Elmt;
+ -------------------------
+ -- Prepend_Unique_Elmt --
+ -------------------------
+
+ procedure Prepend_Unique_Elmt (N : Node_Or_Entity_Id; To : Elist_Id) is
+ begin
+ if not Contains (To, N) then
+ Prepend_Elmt (N, To);
+ end if;
+ end Prepend_Unique_Elmt;
+
-------------
-- Present --
-------------
Index: elists.ads
===================================================================
--- elists.ads (revision 247135)
+++ elists.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, 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- --
@@ -141,6 +141,10 @@
procedure Prepend_Elmt (N : Node_Or_Entity_Id; To : Elist_Id);
-- Appends N at the beginning of To, allocating a new element
+ procedure Prepend_Unique_Elmt (N : Node_Or_Entity_Id; To : Elist_Id);
+ -- Like Prepend_Elmt, except that a check is made to see if To already
+ -- contains N and if so the call has no effect.
+
procedure Insert_Elmt_After (N : Node_Or_Entity_Id; Elmt : Elmt_Id);
-- Add a new element (N) right after the pre-existing element Elmt
-- It is invalid to call this subprogram with Elmt = No_Elmt.
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 247146)
+++ exp_ch3.adb (working copy)
@@ -7515,7 +7515,7 @@
-- verification of pragma Default_Initial_Condition's expression.
if Has_DIC (Def_Id) then
- Build_DIC_Procedure_Body (Def_Id);
+ Build_DIC_Procedure_Body (Def_Id, For_Freeze => True);
end if;
-- Generate the [spec and] body of the invariant procedure tasked with
More information about the Gcc-patches
mailing list