===================================================================
@@ -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
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.