[Ada] Default_Initial_Condition attributes apply to the base type
Arnaud Charlet
charlet@adacore.com
Fri May 22 12:45:00 GMT 2015
This patch modifies the implementation of pragma Default_Initial_Condition to
ensure that all internal attributes related to this annotation apply to the
base type.
------------
-- Source --
------------
-- gen_tester.ads
generic
type Type_To_Test is private;
Test_Id : Positive;
procedure Gen_Tester;
-- gen_tester.adb
with Ada.Assertions; use Ada.Assertions;
with Ada.Text_IO; use Ada.Text_IO;
procedure Gen_Tester is
begin
declare
Val : Type_To_Test;
pragma Unreferenced (Val);
begin
Put_Line ("ERROR" & Test_Id'Img & ": DIC check failed");
end;
exception
when Assertion_Error => Put_Line ("OK" & Test_Id'Img);
when others => Put_Line ("ERROR" & Test_Id'Img & ": unexpected exception");
end Gen_Tester;
-- dic.ads
package DIC is
type T1 is private
with Default_Initial_Condition => To_Int (T1) = 1;
type T2 is private
with Default_Initial_Condition => To_Int (T2) = 10;
subtype S1 is T1;
subtype S2 is T2;
function To_Int (Val : T1) return Integer;
function To_Int (Val : T2) return Integer;
procedure Test_DIC;
private
type T1 is new Integer
with Default_Value => 100;
type T2 is new T1;
subtype S3 is T1;
subtype S4 is T2;
end DIC;
-- dic.adb
with Gen_Tester;
package body DIC is
function To_Int (Val : T1) return Integer is
begin
return Integer (Val);
end To_Int;
function To_Int (Val : T2) return Integer is
begin
return Integer (Val);
end To_Int;
procedure Test_DIC is
procedure Test_1 is new Gen_Tester (T1, 1);
procedure Test_2 is new Gen_Tester (T2, 2);
procedure Test_3 is new Gen_Tester (S1, 3);
procedure Test_4 is new Gen_Tester (S2, 4);
procedure Test_5 is new Gen_Tester (S3, 5);
procedure Test_6 is new Gen_Tester (S4, 6);
begin
Test_1;
Test_2;
Test_3;
Test_4;
Test_5;
Test_6;
end Test_DIC;
end DIC;
-- main.adb
with DIC; use DIC;
procedure Main is
begin
Test_DIC;
end Main;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q -gnata main.adb
$ ./main
OK 1
OK 2
OK 3
OK 4
OK 5
OK 6
Tested on x86_64-pc-linux-gnu, committed on trunk
2015-05-22 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.adb (Default_Init_Cond_Procedure): Code cleanup. The
attribute now applies to the base type.
(Has_Default_Init_Cond): Now applies to the base type.
(Has_Inherited_Default_Init_Cond): Now applies to the base type.
(Set_Default_Init_Cond_Procedure): Code cleanup. The attribute now
applies to the base type.
(Set_Has_Default_Init_Cond): Now applies to the base type.
(Set_Has_Inherited_Default_Init_Cond): Now applies to the base type.
* exp_ch3.adb (Expand_N_Object_Declaration): No need to use the
base type when adding a call to the Default_Initial_Condition.
-------------- next part --------------
Index: einfo.adb
===================================================================
--- einfo.adb (revision 223550)
+++ einfo.adb (working copy)
@@ -1448,7 +1448,8 @@
function Has_Default_Init_Cond (Id : E) return B is
begin
- return Flag3 (Id);
+ pragma Assert (Is_Type (Id));
+ return Flag3 (Base_Type (Id));
end Has_Default_Init_Cond;
function Has_Delayed_Aspects (Id : E) return B is
@@ -1543,7 +1544,7 @@
function Has_Inherited_Default_Init_Cond (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
- return Flag133 (Id);
+ return Flag133 (Base_Type (Id));
end Has_Inherited_Default_Init_Cond;
function Has_Initial_Value (Id : E) return B is
@@ -4326,7 +4327,7 @@
procedure Set_Has_Default_Init_Cond (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
- Set_Flag3 (Id, V);
+ Set_Flag3 (Base_Type (Id), V);
end Set_Has_Default_Init_Cond;
procedure Set_Has_Delayed_Aspects (Id : E; V : B := True) is
@@ -4426,7 +4427,7 @@
procedure Set_Has_Inherited_Default_Init_Cond (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
- Set_Flag133 (Id, V);
+ Set_Flag133 (Base_Type (Id), V);
end Set_Has_Inherited_Default_Init_Cond;
procedure Set_Has_Initial_Value (Id : E; V : B := True) is
@@ -6727,21 +6728,21 @@
---------------------------------
function Default_Init_Cond_Procedure (Id : E) return E is
- S : Entity_Id;
+ Subp_Id : Entity_Id;
begin
pragma Assert
(Is_Type (Id)
- and then (Has_Default_Init_Cond (Id)
- or Has_Inherited_Default_Init_Cond (Id)));
+ and then (Has_Default_Init_Cond (Id)
+ or Has_Inherited_Default_Init_Cond (Id)));
- S := Subprograms_For_Type (Id);
- while Present (S) loop
- if Is_Default_Init_Cond_Procedure (S) then
- return S;
+ Subp_Id := Subprograms_For_Type (Base_Type (Id));
+ while Present (Subp_Id) loop
+ if Is_Default_Init_Cond_Procedure (Subp_Id) then
+ return Subp_Id;
end if;
- S := Subprograms_For_Type (S);
+ Subp_Id := Subprograms_For_Type (Subp_Id);
end loop;
return Empty;
@@ -8282,26 +8283,28 @@
-------------------------------------
procedure Set_Default_Init_Cond_Procedure (Id : E; V : E) is
- S : Entity_Id;
+ Base_Typ : Entity_Id;
+ Subp_Id : Entity_Id;
begin
pragma Assert
- (Is_Type (Id) and then (Has_Default_Init_Cond (Id)
- or
- Has_Inherited_Default_Init_Cond (Id)));
+ (Is_Type (Id)
+ and then (Has_Default_Init_Cond (Id)
+ or Has_Inherited_Default_Init_Cond (Id)));
+ Base_Typ := Base_Type (Id);
- S := Subprograms_For_Type (Id);
- Set_Subprograms_For_Type (Id, V);
- Set_Subprograms_For_Type (V, S);
+ Subp_Id := Subprograms_For_Type (Base_Typ);
+ Set_Subprograms_For_Type (Base_Typ, V);
+ Set_Subprograms_For_Type (V, Subp_Id);
-- Check for a duplicate procedure
- while Present (S) loop
- if Is_Default_Init_Cond_Procedure (S) then
+ while Present (Subp_Id) loop
+ if Is_Default_Init_Cond_Procedure (Subp_Id) then
raise Program_Error;
end if;
- S := Subprograms_For_Type (S);
+ Subp_Id := Subprograms_For_Type (Subp_Id);
end loop;
end Set_Default_Init_Cond_Procedure;
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 223476)
+++ exp_ch3.adb (working copy)
@@ -6147,14 +6147,14 @@
-- Note that the check is generated for source objects only
if Comes_From_Source (Def_Id)
- and then (Has_Default_Init_Cond (Base_Typ)
+ and then (Has_Default_Init_Cond (Typ)
or else
- Has_Inherited_Default_Init_Cond (Base_Typ))
+ Has_Inherited_Default_Init_Cond (Typ))
and then not Has_Init_Expression (N)
then
declare
DIC_Call : constant Node_Id :=
- Build_Default_Init_Cond_Call (Loc, Def_Id, Base_Typ);
+ Build_Default_Init_Cond_Call (Loc, Def_Id, Typ);
begin
if Present (Next_N) then
Insert_Before_And_Analyze (Next_N, DIC_Call);
More information about the Gcc-patches
mailing list