* [Ada] Fixes to preelaborable initialization handling
@ 2011-08-01 12:35 Arnaud Charlet
0 siblings, 0 replies; only message in thread
From: Arnaud Charlet @ 2011-08-01 12:35 UTC (permalink / raw)
To: gcc-patches; +Cc: Thomas Quinot
[-- Attachment #1: Type: text/plain, Size: 3915 bytes --]
This change updates the circuitry that handles the preelaborable initialization
property for controlled types. It fixes several bugs whereby some types
would erroneously be treated as not having preelaborable initialization.
It also implements one of the changes in AI05-028 for Ada 2012, to the
effect that a controlled type with an overriding Initialize primitive that
is a null subprogram does have preelaborable initialization.
The following compilations must produce the indicated results:
$ gcc -c -gnat05 q4_good_05.ads
<quiet acceptance>
$ gcc -c -gnat05 q4_bad_05.ads
q4_bad_05.ads:4:43: actual for "T" must have preelaborable initialization
q4_bad_05.ads:5:43: actual for "T" must have preelaborable initialization
q4_bad_05.ads:6:43: actual for "T" must have preelaborable initialization
$ gcc -c -gnat12 q4_good_12.ads
<quiet acceptance>
$ gcc -c -gnat12 q4_bad_12.ads
q4_bad_12.ads:4:43: actual for "T" must have preelaborable initialization
q4_bad_12.ads:5:43: actual for "T" must have preelaborable initialization
with Q4_Types;
with Q4_Gen;
package Q4_Bad_05 is
package I1 is new Q4_Gen (T => Q4_Types.T1_No_Preelab);
package I2 is new Q4_Gen (T => Q4_Types.T2_No_Preelab);
package I3 is new Q4_Gen (T => Q4_Types.T1_Preelab12);
end Q4_Bad_05;
with Q4_Types;
with Q4_Gen;
package Q4_Bad_12 is
package I1 is new Q4_Gen (T => Q4_Types.T1_No_Preelab);
package I2 is new Q4_Gen (T => Q4_Types.T2_No_Preelab);
end Q4_Bad_12;
with Q4_Types;
with Q4_Gen;
package Q4_Bad_Inst is new Q4_Gen (T => Q4_Types.T99);
generic
type T (<>) is private;
pragma Preelaborable_Initialization (T);
package Q4_Gen is
end Q4_Gen;
with Q4_Types;
with Q4_Gen;
package Q4_Good_05 is
package I1 is new Q4_Gen (T => Q4_Types.T1_Preelab05);
package I2 is new Q4_Gen (T => Q4_Types.T2_Preelab05);
package I3 is new Q4_Gen (T => Q4_Types.T3_Preelab05);
end Q4_Good_05;
with Q4_Types;
with Q4_Gen;
package Q4_Good_12 is
package I1 is new Q4_Gen (T => Q4_Types.T1_Preelab12);
end Q4_Good_12;
package body Q4_Types is
procedure Initialize (X : in out T2) is begin null; end Initialize;
end Q4_Types;
with Ada.Finalization;
package Q4_Types is
-- The following types have preelaborable initialization in Ada 2005:
type T1_Preelab05 is new Ada.Finalization.Controlled with null record;
procedure Initialize (X : in out T1_Preelab05; Y : Integer);
-- Non overriding Initialize procedure
type T2_Preelab05 is new T1_Preelab05 with null record;
procedure Initialize (X : in out T2_Preelab05; Y : Integer);
-- Overriding Initialize procedure, but not for the predefined Initialize??
type T3_Preelab05 is new Ada.Finalization.Controlled with null record;
function Initialize (X : T3_Preelab05) return Integer;
-- The following type has never preelaborable initialization
type T1_No_Preelab is new Ada.Finalization.Controlled with null record;
procedure Initialize (X : in out T1_No_Preelab);
type T2_No_Preelab is new T1_No_Preelab with null record;
procedure Initialize (X : in out T2_No_Preelab) is null;
-- Null Initialize procedure, but ancestor type does not have preelab
-- initialization anyway.
-- The following type has preelaborable initialization in Ada 2012
-- but not in Ada 2005:
type T1_Preelab12 is new Ada.Finalization.Controlled with null record;
procedure Initialize (X : in out T1_Preelab12) is null;
end Q4_Types;
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-01 Thomas Quinot <quinot@adacore.com>
* sem_util.adb, sem_util.ads (Has_Overriding_Initialize): Make function
conformant with its spec (return True only for types that have
an overriding Initialize primitive operation that prevents them from
having preelaborable initialization).
* sem_cat.adb (Validate_Object_Declaration): Fix test for preelaborable
initialization for controlled types in Ada 2005 or later mode.
[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 4531 bytes --]
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 176998)
+++ sem_util.adb (working copy)
@@ -4889,51 +4889,48 @@
function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
BT : constant Entity_Id := Base_Type (T);
- Comp : Entity_Id;
P : Elmt_Id;
begin
if Is_Controlled (BT) then
+ if Is_RTU (Scope (BT), Ada_Finalization) then
+ return False;
- -- For derived types, check immediate ancestor, excluding
- -- Controlled itself.
-
- if Is_Derived_Type (BT)
- and then not In_Predefined_Unit (Etype (BT))
- and then Has_Overriding_Initialize (Etype (BT))
- then
- return True;
-
elsif Present (Primitive_Operations (BT)) then
P := First_Elmt (Primitive_Operations (BT));
while Present (P) loop
- if Chars (Node (P)) = Name_Initialize
- and then Comes_From_Source (Node (P))
- then
- return True;
- end if;
+ declare
+ Init : constant Entity_Id := Node (P);
+ Formal : constant Entity_Id := First_Formal (Init);
+ begin
+ if Ekind (Init) = E_Procedure
+ and then Chars (Init) = Name_Initialize
+ and then Comes_From_Source (Init)
+ and then Present (Formal)
+ and then Etype (Formal) = BT
+ and then No (Next_Formal (Formal))
+ and then (Ada_Version < Ada_2012
+ or else not Null_Present (Parent (Init)))
+ then
+ return True;
+ end if;
+ end;
Next_Elmt (P);
end loop;
end if;
- return False;
+ -- Here if type itself does not have a non-null Initialize operation:
+ -- check immediate ancestor.
- elsif Has_Controlled_Component (BT) then
- Comp := First_Component (BT);
- while Present (Comp) loop
- if Has_Overriding_Initialize (Etype (Comp)) then
- return True;
- end if;
-
- Next_Component (Comp);
- end loop;
-
- return False;
-
- else
- return False;
+ if Is_Derived_Type (BT)
+ and then Has_Overriding_Initialize (Etype (BT))
+ then
+ return True;
+ end if;
end if;
+
+ return False;
end Has_Overriding_Initialize;
--------------------------------------
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 176998)
+++ sem_util.ads (working copy)
@@ -587,7 +587,9 @@
function Has_Overriding_Initialize (T : Entity_Id) return Boolean;
-- Predicate to determine whether a controlled type has a user-defined
- -- Initialize primitive, which makes the type not preelaborable.
+ -- Initialize primitive (and, in Ada 2012, whether that primitive is
+ -- non-null), which causes the type to not have preelaborable
+ -- initialization.
function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean;
-- Return True iff type E has preelaborable initialization as defined in
Index: sem_cat.adb
===================================================================
--- sem_cat.adb (revision 176998)
+++ sem_cat.adb (working copy)
@@ -1268,7 +1268,17 @@
end if;
end if;
- if Has_Overriding_Initialize (ET) then
+ -- For controlled type or type with controlled component, check
+ -- preelaboration flag, as there may be a non-null Initialize
+ -- primitive. For language versions earlier than Ada 2005,
+ -- there is no notion of preelaborable initialization, and the
+ -- rules for controlled objects are enforced in
+ -- Validate_Controlled_Object.
+
+ if (Is_Controlled (ET) or else Has_Controlled_Component (ET))
+ and then Ada_Version >= Ada_2005
+ and then not Has_Preelaborable_Initialization (ET)
+ then
Error_Msg_NE
("controlled type& does not have"
& " preelaborable initialization", N, ET);
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2011-08-01 12:35 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2011-08-01 12:35 [Ada] Fixes to preelaborable initialization handling 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).