* [Ada] Spurious error on Default_Initial_Condition
@ 2017-01-20 10:36 Arnaud Charlet
0 siblings, 0 replies; only message in thread
From: Arnaud Charlet @ 2017-01-20 10:36 UTC (permalink / raw)
To: gcc-patches; +Cc: Hristian Kirtchev
[-- Attachment #1: Type: text/plain, Size: 5944 bytes --]
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.
[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 12610 bytes --]
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 244691)
+++ sem_ch3.adb (working copy)
@@ -7444,6 +7444,7 @@
Set_Full_View (Derived_Type, Full_Der);
else
Set_Underlying_Full_View (Derived_Type, Full_Der);
+ Set_Is_Underlying_Full_View (Full_Der);
end if;
if not Is_Base_Type (Derived_Type) then
@@ -7501,6 +7502,7 @@
Set_Full_View (Derived_Type, Full_Der);
else
Set_Underlying_Full_View (Derived_Type, Full_Der);
+ Set_Is_Underlying_Full_View (Full_Der);
end if;
-- In any case, the primitive operations are inherited from the
@@ -7607,6 +7609,7 @@
else
Build_Full_Derivation;
Set_Underlying_Full_View (Derived_Type, Full_Der);
+ Set_Is_Underlying_Full_View (Full_Der);
end if;
-- The full view will be used to swap entities on entry/exit to
@@ -10018,6 +10021,7 @@
Analyze (Indic);
Set_Underlying_Full_View (Typ, Full_View (Subt));
+ Set_Is_Underlying_Full_View (Full_View (Subt));
end Build_Underlying_Full_View;
-------------------------------
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 244691)
+++ exp_util.adb (working copy)
@@ -1736,13 +1736,24 @@
-- Start of processing for Build_DIC_Procedure_Body
begin
- Work_Typ := Typ;
+ Work_Typ := Base_Type (Typ);
- -- The input type denotes the implementation base type of a constrained
- -- array type. Work with the first subtype as the DIC pragma is on its
- -- rep item chain.
+ -- Do not process class-wide types as these are Itypes, but lack a first
+ -- subtype (see below).
- if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
+ if Is_Class_Wide_Type (Work_Typ) then
+ return;
+
+ -- Do not process the underlying full view of a private type. There is
+ -- no way to get back to the partial view, plus the body will be built
+ -- by the full view or the base type.
+
+ elsif Is_Underlying_Full_View (Work_Typ) then
+ return;
+
+ -- Use the first subtype when dealing with various base types
+
+ elsif Is_Itype (Work_Typ) then
Work_Typ := First_Subtype (Work_Typ);
-- The input denotes the corresponding record type of a protected or a
@@ -1964,13 +1975,24 @@
-- The working type
begin
- Work_Typ := Typ;
+ Work_Typ := Base_Type (Typ);
- -- The input type denotes the implementation base type of a constrained
- -- array type. Work with the first subtype as the DIC pragma is on its
- -- rep item chain.
+ -- Do not process class-wide types as these are Itypes, but lack a first
+ -- subtype (see below).
- if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
+ if Is_Class_Wide_Type (Work_Typ) then
+ return;
+
+ -- Do not process the underlying full view of a private type. There is
+ -- no way to get back to the partial view, plus the body will be built
+ -- by the full view or the base type.
+
+ elsif Is_Underlying_Full_View (Work_Typ) then
+ return;
+
+ -- Use the first subtype when dealing with various base types
+
+ elsif Is_Itype (Work_Typ) then
Work_Typ := First_Subtype (Work_Typ);
-- The input denotes the corresponding record type of a protected or a
Index: sem_ch7.adb
===================================================================
--- sem_ch7.adb (revision 244691)
+++ sem_ch7.adb (working copy)
@@ -2178,6 +2178,7 @@
then
Set_Full_View (Id, Underlying_Full_View (Full));
Set_Underlying_Full_View (Id, Full);
+ Set_Is_Underlying_Full_View (Full);
Set_Underlying_Full_View (Full, Empty);
Set_Is_Frozen (Full_View (Id));
Index: einfo.adb
===================================================================
--- einfo.adb (revision 244691)
+++ einfo.adb (working copy)
@@ -614,8 +614,8 @@
-- Is_Ignored_Transient Flag295
-- Has_Partial_Visible_Refinement Flag296
-- Is_Entry_Wrapper Flag297
+ -- Is_Underlying_Full_View Flag298
- -- (unused) Flag298
-- (unused) Flag299
-- (unused) Flag300
@@ -2612,6 +2612,11 @@
return Flag117 (Implementation_Base_Type (Id));
end Is_Unchecked_Union;
+ function Is_Underlying_Full_View (Id : E) return B is
+ begin
+ return Flag298 (Id);
+ end Is_Underlying_Full_View;
+
function Is_Underlying_Record_View (Id : E) return B is
begin
return Flag246 (Id);
@@ -5709,6 +5714,12 @@
Set_Flag117 (Id, V);
end Set_Is_Unchecked_Union;
+ procedure Set_Is_Underlying_Full_View (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag298 (Id, V);
+ end Set_Is_Underlying_Full_View;
+
procedure Set_Is_Underlying_Record_View (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Record_Type);
@@ -9457,6 +9468,7 @@
W ("Is_Trivial_Subprogram", Flag235 (Id));
W ("Is_True_Constant", Flag163 (Id));
W ("Is_Unchecked_Union", Flag117 (Id));
+ W ("Is_Underlying_Full_View", Flag298 (Id));
W ("Is_Underlying_Record_View", Flag246 (Id));
W ("Is_Unimplemented", Flag284 (Id));
W ("Is_Unsigned_Type", Flag144 (Id));
Index: einfo.ads
===================================================================
--- einfo.ads (revision 244691)
+++ einfo.ads (working copy)
@@ -3236,6 +3236,11 @@
-- Defined in all entities. Set only in record types to which the
-- pragma Unchecked_Union has been validly applied.
+-- Is_Underlying_Full_View (Flag298)
+-- Defined in all entities. Set for types which represent the true full
+-- view of a private type completed by another private type. For further
+-- details, see attribute Underlying_Full_View.
+
-- Is_Underlying_Record_View (Flag246) [base type only]
-- Defined in all entities. Set only in record types that represent the
-- underlying record view. This view is built for derivations of types
@@ -7183,6 +7188,7 @@
function Is_Trivial_Subprogram (Id : E) return B;
function Is_True_Constant (Id : E) return B;
function Is_Unchecked_Union (Id : E) return B;
+ function Is_Underlying_Full_View (Id : E) return B;
function Is_Underlying_Record_View (Id : E) return B;
function Is_Unimplemented (Id : E) return B;
function Is_Unsigned_Type (Id : E) return B;
@@ -7868,6 +7874,7 @@
procedure Set_Is_Trivial_Subprogram (Id : E; V : B := True);
procedure Set_Is_True_Constant (Id : E; V : B := True);
procedure Set_Is_Unchecked_Union (Id : E; V : B := True);
+ procedure Set_Is_Underlying_Full_View (Id : E; V : B := True);
procedure Set_Is_Underlying_Record_View (Id : E; V : B := True);
procedure Set_Is_Unimplemented (Id : E; V : B := True);
procedure Set_Is_Unsigned_Type (Id : E; V : B := True);
@@ -8705,6 +8712,7 @@
pragma Inline (Is_True_Constant);
pragma Inline (Is_Type);
pragma Inline (Is_Unchecked_Union);
+ pragma Inline (Is_Underlying_Full_View);
pragma Inline (Is_Underlying_Record_View);
pragma Inline (Is_Unimplemented);
pragma Inline (Is_Unsigned_Type);
@@ -9180,6 +9188,7 @@
pragma Inline (Set_Is_Trivial_Subprogram);
pragma Inline (Set_Is_True_Constant);
pragma Inline (Set_Is_Unchecked_Union);
+ pragma Inline (Set_Is_Underlying_Full_View);
pragma Inline (Set_Is_Underlying_Record_View);
pragma Inline (Set_Is_Unimplemented);
pragma Inline (Set_Is_Unsigned_Type);
Index: freeze.adb
===================================================================
--- freeze.adb (revision 244691)
+++ freeze.adb (working copy)
@@ -2087,6 +2087,12 @@
-- Determine whether an arbitrary entity is subject to Boolean aspect
-- Import and its value is specified as True.
+ procedure Inherit_Freeze_Node
+ (Fnod : Node_Id;
+ Typ : Entity_Id);
+ -- Set type Typ's freeze node to refer to Fnode. This routine ensures
+ -- that any attributes attached to Typ's original node are preserved.
+
procedure Wrap_Imported_Subprogram (E : Entity_Id);
-- If E is an entity for an imported subprogram with pre/post-conditions
-- then this procedure will create a wrapper to ensure that proper run-
@@ -4726,6 +4732,60 @@
return False;
end Has_Boolean_Aspect_Import;
+ -------------------------
+ -- Inherit_Freeze_Node --
+ -------------------------
+
+ procedure Inherit_Freeze_Node
+ (Fnod : Node_Id;
+ Typ : Entity_Id)
+ is
+ Typ_Fnod : constant Node_Id := Freeze_Node (Typ);
+
+ begin
+ Set_Freeze_Node (Typ, Fnod);
+ Set_Entity (Fnod, Typ);
+
+ -- The input type had an existing node. Propagate relevant attributes
+ -- from the old freeze node to the inherited freeze node.
+
+ -- ??? if both freeze nodes have attributes, would they differ?
+
+ if Present (Typ_Fnod) then
+
+ -- Attribute Access_Types_To_Process
+
+ if Present (Access_Types_To_Process (Typ_Fnod))
+ and then No (Access_Types_To_Process (Fnod))
+ then
+ Set_Access_Types_To_Process (Fnod,
+ Access_Types_To_Process (Typ_Fnod));
+ end if;
+
+ -- Attribute Actions
+
+ if Present (Actions (Typ_Fnod)) and then No (Actions (Fnod)) then
+ Set_Actions (Fnod, Actions (Typ_Fnod));
+ end if;
+
+ -- Attribute First_Subtype_Link
+
+ if Present (First_Subtype_Link (Typ_Fnod))
+ and then No (First_Subtype_Link (Fnod))
+ then
+ Set_First_Subtype_Link (Fnod, First_Subtype_Link (Typ_Fnod));
+ end if;
+
+ -- Attribute TSS_Elist
+
+ if Present (TSS_Elist (Typ_Fnod))
+ and then No (TSS_Elist (Fnod))
+ then
+ Set_TSS_Elist (Fnod, TSS_Elist (Typ_Fnod));
+ end if;
+ end if;
+ end Inherit_Freeze_Node;
+
------------------------------
-- Wrap_Imported_Subprogram --
------------------------------
@@ -5776,9 +5836,9 @@
F_Node := Freeze_Node (Full);
if Present (F_Node) then
- Set_Freeze_Node (Full_View (E), F_Node);
- Set_Entity (F_Node, Full_View (E));
-
+ Inherit_Freeze_Node
+ (Fnod => F_Node,
+ Typ => Full_View (E));
else
Set_Has_Delayed_Freeze (Full_View (E), False);
Set_Freeze_Node (Full_View (E), Empty);
@@ -5789,9 +5849,9 @@
F_Node := Freeze_Node (Full_View (E));
if Present (F_Node) then
- Set_Freeze_Node (E, F_Node);
- Set_Entity (F_Node, E);
-
+ Inherit_Freeze_Node
+ (Fnod => F_Node,
+ Typ => E);
else
-- {Incomplete,Private}_Subtypes with Full_Views
-- constrained by discriminants.
@@ -5847,9 +5907,9 @@
F_Node := Freeze_Node (Underlying_Full_View (E));
if Present (F_Node) then
- Set_Freeze_Node (E, F_Node);
- Set_Entity (F_Node, E);
-
+ Inherit_Freeze_Node
+ (Fnod => F_Node,
+ Typ => E);
else
Set_Has_Delayed_Freeze (E, False);
Set_Freeze_Node (E, Empty);
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2017-01-20 10:32 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2017-01-20 10:36 [Ada] Spurious error on Default_Initial_Condition Arnaud Charlet
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).