diff mbox

[Ada] Preelaborable initialization for derived types

Message ID 20101026105151.GA21302@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Oct. 26, 2010, 10:51 a.m. UTC 
This change fixes a bug in the predicate testing whether a type has
preelaborable initialization, in the case of a derived record types that
changes the default value of a discriminant of its parent type.

The following compilation must be rejected:
$ gcc -c preelab_der_pvt.ads
preelab_der_pvt.ads:12:09: full view of "T2" does not have preelaborable initialization

package Preelab_Der_Pvt is
   type T1 is private;
   pragma Preelaborable_Initialization (T1);

   type T2 is private;
   pragma Preelaborable_Initialization (T2);

private
   type T1 (D : Integer := 0) is null record;

   function F return Integer;
   type T2 (D : Integer := F) is new T1 (D => D);
   --  Error: T2 does not have preelaborable initialization

end Preelab_Der_Pvt;

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

2010-10-26  Thomas Quinot  <quinot@adacore.com>

	* sem_util.adb (Has_Preelaborable_Initialization.Check_Components):
	For a discriminant, use Discriminant_Default_Value rather than
	Expression (Declaration_Node (D)).
diff mbox

Patch

Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 165939)
+++ sem_util.adb	(working copy)
@@ -5121,36 +5121,50 @@  package body Sem_Util is
 
             --  We are interested only in components and discriminants
 
-            if Ekind_In (Ent, E_Component, E_Discriminant) then
+            Exp := Empty;
+            case Ekind (Ent) is
+               when E_Component =>
+
+                  --  Get default expression if any. If there is no declaration
+                  --  node, it means we have an internal entity. The parent and
+                  --  tag fields are examples of such entities. For such cases,
+                  --  we just test the type of the entity.
 
-               --  Get default expression if any. If there is no declaration
-               --  node, it means we have an internal entity. The parent and
-               --  tag fields are examples of such entities. For these cases,
-               --  we just test the type of the entity.
+                  if Present (Declaration_Node (Ent)) then
+                     Exp := Expression (Declaration_Node (Ent));
+                  end if;
 
-               if Present (Declaration_Node (Ent)) then
-                  Exp := Expression (Declaration_Node (Ent));
-               else
-                  Exp := Empty;
-               end if;
+               when E_Discriminant =>
 
-               --  A component has PI if it has no default expression and the
-               --  component type has PI.
+                  --  Note: for a renamed discriminant, the Declaration_Node
+                  --  may point to the one from the ancestor, and have a
+                  --  different expression, so use the proper attribute to
+                  --  retrieve the expression from the derived constraint.
 
-               if No (Exp) then
-                  if not Has_Preelaborable_Initialization (Etype (Ent)) then
-                     Has_PE := False;
-                     exit;
-                  end if;
+                  Exp := Discriminant_Default_Value (Ent);
 
-               --  Require the default expression to be preelaborable
+               when others =>
+                  goto Check_Next_Entity;
 
-               elsif not Is_Preelaborable_Expression (Exp) then
+            end case;
+
+            --  A component has PI if it has no default expression and the
+            --  component type has PI.
+
+            if No (Exp) then
+               if not Has_Preelaborable_Initialization (Etype (Ent)) then
                   Has_PE := False;
                   exit;
                end if;
+
+            --  Require the default expression to be preelaborable
+
+            elsif not Is_Preelaborable_Expression (Exp) then
+               Has_PE := False;
+               exit;
             end if;
 
+         <<Check_Next_Entity>>
             Next_Entity (Ent);
          end loop;
       end Check_Components;