[Ada] Default_Initial_Condition not inherited properly
Arnaud Charlet
charlet@adacore.com
Fri Oct 17 08:47:00 GMT 2014
This patch modifies the inheritance of pragma Default_Initial_Condition to
ensure that a private derived type inherits the default initial condition
procedure from its parent type rather than attempt to build one of its own.
------------
-- Source --
------------
-- grand_pack.ads
package Grand_Pack is
type Grand_Typ is private
with Default_Initial_Condition => Grand_Fail;
function Grand_Fail return Boolean is (False);
private
type Grand_Typ is record
Data : Integer := 123;
end record;
end Grand_Pack;
-- parent_pack.ads
with Grand_Pack; use Grand_Pack;
package Parent_Pack is
type Parent_Typ is private
with Default_Initial_Condition => Parent_Fail;
function Parent_Fail return Boolean is (False);
private
type Parent_Typ is new Grand_Typ;
end Parent_Pack;
-- child_pack.ads
with Parent_Pack; use Parent_Pack;
package Child_Pack is
type Child_Typ is private;
private
type Child_Typ is new Parent_Typ;
end Child_Pack;
-- gen_checker.ads
generic
type Priv_Typ is private;
Test_Id : String;
package Gen_Checker is
procedure Check_DIC;
end Gen_Checker;
-- gen_checker.adb
with Ada.Assertions; use Ada.Assertions;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Text_IO; use Ada.Text_IO;
package body Gen_Checker is
procedure Check_DIC is
begin
declare
Obj : Priv_Typ;
pragma Unreferenced (Obj);
begin
Put_Line ("ERROR: " & Test_Id & " should fail");
end;
exception
when AE : Assertion_Error =>
Put_Line ("OK");
Put_Line (Exception_Message (AE));
when others =>
Put_Line ("ERROR: " & Test_Id & " unexpected exception");
end Check_DIC;
end Gen_Checker;
-- inheritance_checks.adb
with Child_Pack; use Child_Pack;
with Gen_Checker;
with Grand_Pack; use Grand_Pack;
with Parent_Pack; use Parent_Pack;
procedure Inheritance_Checks is
package Check_1 is new Gen_Checker (Grand_Typ, "Test 1");
package Check_2 is new Gen_Checker (Parent_Typ, "Test 2");
package Check_3 is new Gen_Checker (Child_Typ, "Test 3");
begin
Check_1.Check_DIC;
Check_2.Check_DIC;
Check_3.Check_DIC;
end Inheritance_Checks;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q -gnata inheritance_checks.adb
$ ./inheritance_checks
OK
Default_Initial_Condition failed at grand_pack.ads:3
OK
Default_Initial_Condition failed at parent_pack.ads:5
OK
Default_Initial_Condition failed at parent_pack.ads:5
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-10-17 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch3.adb (Propagate_Default_Init_Cond_Attributes): A derived type
inherits the attributes related to pragma Default_Initial_Condition
from its parent type.
-------------- next part --------------
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 216370)
+++ sem_ch3.adb (working copy)
@@ -20388,10 +20388,19 @@
-- Start of processing for Propagate_Default_Init_Cond_Attributes
begin
- -- A full view inherits the attributes from its private view
+ if Has_Default_Init_Cond (From_Typ) then
- if Has_Default_Init_Cond (From_Typ) then
- Set_Has_Default_Init_Cond (To_Typ);
+ -- A derived type inherits the attributes from its parent type
+
+ if Parent_To_Derivation then
+ Set_Has_Inherited_Default_Init_Cond (To_Typ);
+
+ -- A full view shares the attributes with its private view
+
+ else
+ Set_Has_Default_Init_Cond (To_Typ);
+ end if;
+
Inherit_Procedure := True;
-- Due to the order of expansion, a derived private type is processed
More information about the Gcc-patches
mailing list