sem_aggr.adb (Resolve_Record_Aggregate): In the case of a box association for an access component...

2007-10-15  Gary Dismukes  <dismukes@adacore.com>

	* sem_aggr.adb (Resolve_Record_Aggregate): In the case of a box
	association for an access component, add an association with null as
	the expression. Remove testing for array subtypes and the setting in
	that case of Ctyp to the array component type, which prevented proper
	inclusion of an association for null-initialized arrays. Collapse
	condition that tests for array subtypes into just a test of
	Is_Partially_Initialized_Type (which already covers arrays anyway).

From-SVN: r129331

1 files changed, 50 insertions, 25 deletions

diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 55385e4..3d5b62d 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -1258,10 +1258,13 @@ package body Sem_Aggr is
          Val_AL : Uint;
          Val_AH : Uint;
 
-         OK_L  : Boolean;
-         OK_H  : Boolean;
+         OK_L : Boolean;
+         OK_H : Boolean;
+
          OK_AL : Boolean;
-         OK_AH : Boolean;
+         OK_AH  : Boolean;
+         pragma Warnings (Off, OK_AL);
+         pragma Warnings (Off, OK_AH);
 
       begin
          if Raises_Constraint_Error (N)
@@ -1464,7 +1467,8 @@ package body Sem_Aggr is
       Choice  : Node_Id;
       Expr    : Node_Id;
 
-      Who_Cares : Node_Id;
+      Discard : Node_Id;
+      pragma Warnings (Off, Discard);
 
       Aggr_Low  : Node_Id := Empty;
       Aggr_High : Node_Id := Empty;
@@ -1881,7 +1885,7 @@ package body Sem_Aggr is
 
          else
             if Others_Allowed then
-               Get_Index_Bounds (Index_Constr, Aggr_Low, Who_Cares);
+               Get_Index_Bounds (Index_Constr, Aggr_Low, Discard);
             else
                Aggr_Low := Index_Typ_Low;
             end if;
@@ -2984,27 +2988,17 @@ package body Sem_Aggr is
          Expr := Get_Value (Component, Component_Associations (N), True);
 
          --  Note: The previous call to Get_Value sets the value of the
-         --  variable Is_Box_Present
+         --  variable Is_Box_Present.
 
          --  Ada 2005 (AI-287): Handle components with default initialization.
          --  Note: This feature was originally added to Ada 2005 for limited
          --  but it was finally allowed with any type.
 
          if Is_Box_Present then
-            declare
-               Is_Array_Subtype : constant Boolean :=
-                                    Ekind (Etype (Component)) =
-                                                           E_Array_Subtype;
-
-               Ctyp : Entity_Id;
+            Check_Box_Component : declare
+               Ctyp : constant Entity_Id := Etype (Component);
 
             begin
-               if Is_Array_Subtype then
-                  Ctyp := Component_Type (Base_Type (Etype (Component)));
-               else
-                  Ctyp := Etype (Component);
-               end if;
-
                --  If there is a default expression for the aggregate, copy
                --  it into a new association.
 
@@ -3033,6 +3027,42 @@ package body Sem_Aggr is
                      Expr      => Expr);
                   Set_Has_Self_Reference (N);
 
+               --  A box-defaulted access component gets the value null. Also
+               --  included are components of private types whose underlying
+               --  type is an access type.
+
+               elsif Present (Underlying_Type (Ctyp))
+                 and then Is_Access_Type (Underlying_Type (Ctyp))
+               then
+                  if not Is_Private_Type (Ctyp) then
+                     Add_Association
+                       (Component => Component,
+                        Expr      => Make_Null (Sloc (N)));
+
+                  --  If the component's type is private with an access type as
+                  --  its underlying type then we have to create an unchecked
+                  --  conversion to satisfy type checking.
+
+                  else
+                     declare
+                        Qual_Null : constant Node_Id :=
+                                      Make_Qualified_Expression (Sloc (N),
+                                        Subtype_Mark =>
+                                          New_Occurrence_Of
+                                            (Underlying_Type (Ctyp), Sloc (N)),
+                                        Expression => Make_Null (Sloc (N)));
+
+                        Convert_Null : constant Node_Id :=
+                                         Unchecked_Convert_To
+                                           (Ctyp, Qual_Null);
+
+                     begin
+                        Analyze_And_Resolve (Convert_Null, Ctyp);
+                        Add_Association
+                          (Component => Component, Expr => Convert_Null);
+                     end;
+                  end if;
+
                elsif Has_Non_Null_Base_Init_Proc (Ctyp)
                  or else not Expander_Active
                then
@@ -3143,16 +3173,11 @@ package body Sem_Aggr is
                --  expand the corresponding assignments and run-time checks).
 
                elsif Present (Expr)
-                 and then
-                   ((not Is_Array_Subtype
-                       and then Is_Partially_Initialized_Type (Component))
-                      or else
-                        (Is_Array_Subtype
-                           and then Is_Partially_Initialized_Type (Ctyp)))
+                 and then Is_Partially_Initialized_Type (Ctyp)
                then
                   Resolve_Aggr_Expr (Expr, Component);
                end if;
-            end;
+            end Check_Box_Component;
 
          elsif No (Expr) then