[Ada] Spurious error on Default_Initial_Condition

This patch modifies the generation of the Default_Initial_Condition procedure
to disregard class-wide types and the underlying full views of private types.
In addition, the patch preserves the attributes of freeze nodes when the
partial and/or full views of a private type inherit the freeze node of the
underlying full view.

------------
-- Source --
------------

--  pack_1.ads

package Pack_1 is
   type Untag_Par (Size : Natural) is private
     with Default_Initial_Condition => Is_OK_UP (Untag_Par);

   type Tag_Par (Size : Natural) is tagged private
     with Default_Initial_Condition => Is_OK_TP (Tag_Par);

   type Lim_Untag_Par (Size : Natural) is limited private
     with Default_Initial_Condition => Is_OK_LUP (Lim_Untag_Par);

   type Lim_Tag_Par (Size : Natural) is tagged limited private
     with Default_Initial_Condition => Is_OK_LTP (Lim_Tag_Par);

   function Is_OK_UP  (Obj : Untag_Par)     return Boolean;
   function Is_OK_TP  (Obj : Tag_Par)       return Boolean;
   function Is_OK_LUP (Obj : Lim_Untag_Par) return Boolean;
   function Is_OK_LTP (Obj : Lim_Tag_Par)   return Boolean;

private
   type Untag_Par (Size : Natural) is record
      Comp : Natural := Size;
   end record;

   type Tag_Par (Size : Natural) is tagged record
      Comp : Natural := Size;
   end record;

   type Lim_Untag_Par (Size : Natural) is limited record
      Comp : Natural := Size;
   end record;

   type Lim_Tag_par (Size : Natural) is tagged limited record
      Comp : Natural := Size;
   end record;
end Pack_1;

--  pack_1.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Pack_1 is
   function Is_OK_UP (Obj : Untag_Par) return Boolean is
   begin
      Put_Line ("Untag_Par");
      return True;
   end Is_OK_UP;

   function Is_OK_TP (Obj : Tag_Par) return Boolean is
   begin
      Put_Line ("Tag_Par");
      return True;
   end Is_OK_TP;

   function Is_OK_LUP (Obj : Lim_Untag_Par) return Boolean is
   begin
      Put_Line ("Lim_Untag_Par");
      return True;
   end Is_OK_LUP;

   function Is_OK_LTP (Obj : Lim_Tag_Par) return Boolean is
   begin
      Put_Line ("Lim_Tag_Par");
      return True;
   end Is_OK_LTP;
end Pack_1;

--  pack_2.ads

with Pack_1; use Pack_1;

package Pack_2 is
   type Deriv_1 is private
     with Default_Initial_Condition => Is_OK_Deriv_1 (Deriv_1);

   type Deriv_2 is tagged private
     with Default_Initial_Condition => Is_OK_Deriv_2 (Deriv_2);

   type Deriv_3 is limited private
     with Default_Initial_Condition => Is_OK_Deriv_3 (Deriv_3);

   type Deriv_4 is tagged limited private
     with Default_Initial_Condition => Is_OK_Deriv_4 (Deriv_4);

   type Deriv_5 is private
     with Default_Initial_Condition;

   type Deriv_6 is tagged private
     with Default_Initial_Condition;

   type Deriv_7 is limited private
     with Default_Initial_Condition;

   type Deriv_8 is tagged limited private
     with Default_Initial_Condition;

   function Is_OK_Deriv_1 (Obj : Deriv_1) return Boolean;
   function Is_OK_Deriv_2 (Obj : Deriv_2) return Boolean;
   function Is_OK_Deriv_3 (Obj : Deriv_3) return Boolean;
   function Is_OK_Deriv_4 (Obj : Deriv_4) return Boolean;

private
   type Deriv_1 is new Untag_Par     (1);
   type Deriv_2 is new Tag_Par       (2) with null record;
   type Deriv_3 is new Lim_Untag_Par (3);
   type Deriv_4 is new Lim_Tag_Par   (4) with null record;
   type Deriv_5 is new Untag_Par     (5);
   type Deriv_6 is new Tag_Par       (6) with null record;
   type Deriv_7 is new Lim_Untag_Par (7);
   type Deriv_8 is new Lim_Tag_Par   (8) with null record;

end Pack_2;

--  pack_2.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Pack_2 is
   function Is_OK_Deriv_1 (Obj : Deriv_1) return Boolean is
   begin
      Put_Line ("Deriv_1");
      return True;
   end Is_OK_Deriv_1;

   function Is_OK_Deriv_2 (Obj : Deriv_2) return Boolean is
   begin
      Put_Line ("Deriv_2");
      return True;
   end Is_OK_Deriv_2;

   function Is_OK_Deriv_3 (Obj : Deriv_3) return Boolean is
   begin
      Put_Line ("Deriv_3");
      return True;
   end Is_OK_Deriv_3;

   function Is_OK_Deriv_4 (Obj : Deriv_4) return Boolean is
   begin
      Put_Line ("Deriv_4");
      return True;
   end Is_OK_Deriv_4;
end Pack_2;

--  main.adb

with Pack_2; use Pack_2;

procedure Main is
   Obj_1 : Deriv_1;
   Obj_2 : Deriv_2;
   Obj_3 : Deriv_3;
   Obj_4 : Deriv_4;
   Obj_5 : Deriv_5;
   Obj_6 : Deriv_6;
   Obj_7 : Deriv_7;
   Obj_8 : Deriv_8;
begin
   null;
end Main;

----------------------------
-- Compilation and output --
----------------------------

$ gnatmake -q -gnata main.adb
$ ./main
Deriv_1
Deriv_2
Deriv_3
Deriv_4

Tested on x86_64-pc-linux-gnu, committed on trunk

2017-01-20  Hristian Kirtchev  <kirtchev@adacore.com>

	* einfo.adb Flag298 now denotes Is_Underlying_Full_View.
	(Is_Underlying_Full_View): New routine.
	(Set_Is_Underlying_Full_View): New routine.
	(Write_Entity_Flags): Add an entry for Is_Underlying_Full_View.
	* einfo.ads Add new attribute Is_Underlying_Full_View.
	(Is_Underlying_Full_View): New routine along with pragma Inline.
	(Set_Is_Underlying_Full_View): New routine along with pragma Inline.
	* exp_util.adb (Build_DIC_Procedure_Body): Do not consider
	class-wide types and underlying full views. The first subtype
	is used as the working type for all Itypes, not just array base types.
	(Build_DIC_Procedure_Declaration): Do not consider
	class-wide types and underlying full views. The first subtype
	is used as the working type for all Itypes, not just array
	base types.
	* freeze.adb (Freeze_Entity): Inherit the freeze node of a full
	view or an underlying full view without clobbering the attributes
	of a previous freeze node.
	(Inherit_Freeze_Node): New routine.
	* sem_ch3.adb (Build_Derived_Private_Type): Mark an underlying
	full view as such.
	(Build_Underlying_Full_View): Mark an underlying full view as such.
	* sem_ch7.adb (Install_Private_Declarations): Mark an underlying
	full view as such.

[Ada] Spurious error on Default_Initial_Condition

Commit Message

Patch