exp_aggr.adb (Rewrite_Discriminant): Rewriting must occur only for an expression...

2010-06-22  Thomas Quinot  <quinot@adacore.com>

	* exp_aggr.adb (Rewrite_Discriminant): Rewriting must occur only for an
	expression referring to a discriminal of the type of the aggregate (not
	a discriminal of some other unrelated type), and the prefix in the
	generated selected component must come from Lhs, not Obj.

2010-06-22  Thomas Quinot  <quinot@adacore.com>

	* sem_ch3.adb (Build_Derived_Record_Type): Fix predicate determining
	when to freeze the parent type.

From-SVN: r161195

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index b80c597..0af660d 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,15 @@
+2010-06-22  Thomas Quinot  <quinot@adacore.com>
+
+       * exp_aggr.adb (Rewrite_Discriminant): Rewriting must occur only for an
+       expression referring to a discriminal of the type of the aggregate (not
+       a discriminal of some other unrelated type), and the prefix in the
+       generated selected component must come from Lhs, not Obj.
+
+2010-06-22  Thomas Quinot  <quinot@adacore.com>
+
+       * sem_ch3.adb (Build_Derived_Record_Type): Fix predicate determining
+       when to freeze the parent type.
+
 2010-06-22  Robert Dewar  <dewar@adacore.com>
 
        * s-rannum.adb, a-nudira.adb, types.ads, freeze.adb, sem_aggr.adb,

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index c4e3b01..925a704 100644 (file)
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -93,7 +93,7 @@ package body Exp_Aggr is
 
    function Has_Default_Init_Comps (N : Node_Id) return Boolean;
    --  N is an aggregate (record or array). Checks the presence of default
-   --  initialization (<>) in any component (Ada 2005: AI-287)
+   --  initialization (<>) in any component (Ada 2005: AI-287).
 
    function Is_Static_Dispatch_Table_Aggregate (N : Node_Id) return Boolean;
    --  Returns true if N is an aggregate used to initialize the components
@@ -2431,10 +2431,12 @@ package body Exp_Aggr is
            and then Present (Entity (Expr))
            and then Ekind (Entity (Expr)) = E_In_Parameter
            and then Present (Discriminal_Link (Entity (Expr)))
+           and then Scope (Discriminal_Link (Entity (Expr)))
+                      = Base_Type (Etype (N))
          then
             Rewrite (Expr,
               Make_Selected_Component (Loc,
-                Prefix        => New_Occurrence_Of (Obj, Loc),
+                Prefix        => New_Copy_Tree (Lhs),
                 Selector_Name => Make_Identifier (Loc, Chars (Expr))));
          end if;
          return OK;

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 1cb03ba..f1aaf61 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -6778,10 +6778,12 @@ package body Sem_Ch3 is
          Mark_Rewrite_Insertion (New_Decl);
          Insert_Before (N, New_Decl);
 
-         --  In the tagged case, make sure ancestor is frozen appropriately
+         --  In the extension case, make sure ancestor is frozen appropriately
          --  (see also non-discriminated case below).
 
-         if not Private_Extension or else Is_Interface (Parent_Base) then
+         if Present (Record_Extension_Part (Type_Def))
+              or else Is_Interface (Parent_Base)
+         then
             Freeze_Before (New_Decl, Parent_Type);
          end if;
 
@@ -16667,10 +16669,9 @@ package body Sem_Ch3 is
                end loop;
             end if;
 
-            --  For the tagged case, the two views can share the same
-            --  Primitive Operation list and the same class wide type.
-            --  Update attributes of the class-wide type which depend on
-            --  the full declaration.
+            --  For the tagged case, the two views can share the same primitive
+            --  operations list and the same class-wide type. Update attributes
+            --  of the class-wide type which depend on the full declaration.
 
             if Is_Tagged_Type (Priv_T) then
                Set_Primitive_Operations (Priv_T, Full_List);