[Ada] Default_Initial_Condition not inherited properly

[Arnaud Charlet <charlet at adacore dot com>]

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.

Attachment: difs
Description: Text document