From d8f7b976d7f6ba52d1b71770c6d03ff408294b18 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Wed, 15 Feb 2006 10:37:33 +0100 Subject: [PATCH] exp_aggr.adb (Build_Array_Aggr_Code): Rename variable "Others_Mbox_Present" to "Others_Box_Present" because the mbox... 2006-02-13 Ed Schonberg * exp_aggr.adb (Build_Array_Aggr_Code): Rename variable "Others_Mbox_Present" to "Others_Box_Present" because the mbox concept does not exist in the Ada RM. (Compatible_Int_Bounds): Determine whether two integer range bounds are of equal length and have the same start and end values. (Is_Int_Range_Bounds): Determine whether a node is an integer range. (Build_Record_Aggr_Code): Perform proper sliding of a nested array aggregate when it is part of an object declaration. (Build_Record_Aggr_Code) If the aggregate ttype is a derived type that constrains discriminants of its parent, add explicitly the discriminant constraints of the ancestor by retrieving them from the stored_constraint of the parent. From-SVN: r111057 --- gcc/ada/exp_aggr.adb | 236 ++++++++++++++++++++++++++++++++++++++----- 1 file changed, 212 insertions(+), 24 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 9c9508fa5cc..f4fb029cfe5 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -850,7 +850,7 @@ package body Exp_Aggr is -- Ada 2005 (AI-287): Do nothing else in case of default -- initialized component. - if not Present (Expr) then + if No (Expr) then return Lis; elsif Nkind (Parent (Expr)) = N_Component_Association @@ -918,7 +918,7 @@ package body Exp_Aggr is -- Ada 2005 (AI-287): In case of default initialized component, Expr -- is not present (and therefore we also initialize Expr_Q to empty). - if not Present (Expr) then + if No (Expr) then Expr_Q := Empty; elsif Nkind (Expr) = N_Qualified_Expression then Expr_Q := Expression (Expr); @@ -1018,8 +1018,7 @@ package body Exp_Aggr is -- Ada 2005 (AI-287): In case of default initialized component, call -- the initialization subprogram associated with the component type. - if not Present (Expr) then - + if No (Expr) then if Present (Base_Init_Proc (Etype (Ctype))) or else Has_Task (Base_Type (Ctype)) then @@ -1143,7 +1142,7 @@ package body Exp_Aggr is -- Ada 2005 (AI-287): Nothing else need to be done in case of -- default initialized component. - if not Present (Expr) then + if No (Expr) then null; else @@ -1376,8 +1375,8 @@ package body Exp_Aggr is Expr : Node_Id; Typ : Entity_Id; - Others_Expr : Node_Id := Empty; - Others_Mbox_Present : Boolean := False; + Others_Expr : Node_Id := Empty; + Others_Box_Present : Boolean := False; Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N)); Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N)); @@ -1439,7 +1438,7 @@ package body Exp_Aggr is Set_Loop_Actions (Assoc, New_List); if Box_Present (Assoc) then - Others_Mbox_Present := True; + Others_Box_Present := True; else Others_Expr := Expression (Assoc); end if; @@ -1489,7 +1488,7 @@ package body Exp_Aggr is -- We don't need to generate loops over empty gaps, but if there is -- a single empty range we must analyze the expression for semantics - if Present (Others_Expr) or else Others_Mbox_Present then + if Present (Others_Expr) or else Others_Box_Present then declare First : Boolean := True; @@ -1621,10 +1620,6 @@ package body Exp_Aggr is Attach : Node_Id; Ctrl_Stuff_Done : Boolean := False; - function Get_Constraint_Association (T : Entity_Id) return Node_Id; - -- Returns the first discriminant association in the constraint - -- associated with T, if any, otherwise returns Empty. - function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id; -- Returns the value that the given discriminant of an ancestor -- type should receive (in the absence of a conflict with the @@ -1636,6 +1631,20 @@ package body Exp_Aggr is -- values provided by either an association of the aggregate or -- by the constraint imposed by a parent type (RM95-4.3.2(8)). + function Compatible_Int_Bounds + (Agg_Bounds : Node_Id; + Typ_Bounds : Node_Id) return Boolean; + -- Return true if Agg_Bounds are equal or within Typ_Bounds. It is + -- assumed that both bounds are integer ranges. + + procedure Gen_Ctrl_Actions_For_Aggr; + -- Deal with the various controlled type data structure + -- initializations. + + function Get_Constraint_Association (T : Entity_Id) return Node_Id; + -- Returns the first discriminant association in the constraint + -- associated with T, if any, otherwise returns Empty. + function Init_Controller (Target : Node_Id; Typ : Entity_Id; @@ -1647,9 +1656,9 @@ package body Exp_Aggr is -- it to finalization list F. Init_Pr conditions the call to the -- init proc since it may already be done due to ancestor initialization - procedure Gen_Ctrl_Actions_For_Aggr; - -- Deal with the various controlled type data structure - -- initializations + function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean; + -- Check whether Bounds is a range node and its lower and higher bounds + -- are integers literals. --------------------------------- -- Ancestor_Discriminant_Value -- @@ -1811,6 +1820,22 @@ package body Exp_Aggr is end loop; end Check_Ancestor_Discriminants; + --------------------------- + -- Compatible_Int_Bounds -- + --------------------------- + + function Compatible_Int_Bounds + (Agg_Bounds : Node_Id; + Typ_Bounds : Node_Id) return Boolean + is + Agg_Lo : constant Uint := Intval (Low_Bound (Agg_Bounds)); + Agg_Hi : constant Uint := Intval (High_Bound (Agg_Bounds)); + Typ_Lo : constant Uint := Intval (Low_Bound (Typ_Bounds)); + Typ_Hi : constant Uint := Intval (High_Bound (Typ_Bounds)); + begin + return Typ_Lo <= Agg_Lo and then Agg_Hi <= Typ_Hi; + end Compatible_Int_Bounds; + -------------------------------- -- Get_Constraint_Association -- -------------------------------- @@ -1909,6 +1934,17 @@ package body Exp_Aggr is return L; end Init_Controller; + ------------------------- + -- Is_Int_Range_Bounds -- + ------------------------- + + function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean is + begin + return Nkind (Bounds) = N_Range + and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal + and then Nkind (High_Bound (Bounds)) = N_Integer_Literal; + end Is_Int_Range_Bounds; + ------------------------------- -- Gen_Ctrl_Actions_For_Aggr -- ------------------------------- @@ -2307,12 +2343,62 @@ package body Exp_Aggr is if Has_Discriminants (Typ) and then not Is_Unchecked_Union (Base_Type (Typ)) then - -- ??? The discriminants of the object not inherited in the type - -- of the object should be initialized here + -- If the type is derived, and constrains discriminants of the + -- parent type, these discriminants are not components of the + -- aggregate, and must be initialized explicitly. They are not + -- visible components of the object, but can become visible with + -- a view conversion to the ancestor. - null; + declare + Btype : Entity_Id; + Parent_Type : Entity_Id; + Disc : Entity_Id; + Discr_Val : Elmt_Id; + + begin + Btype := Base_Type (Typ); + + while Is_Derived_Type (Btype) + and then Present (Stored_Constraint (Btype)) + loop + Parent_Type := Etype (Btype); + + Disc := First_Discriminant (Parent_Type); + Discr_Val := + First_Elmt (Stored_Constraint (Base_Type (Typ))); + while Present (Discr_Val) loop - -- Generate discriminant init values + -- Only those discriminants of the parent that are not + -- renamed by discriminants of the derived type need to + -- be added explicitly. + + if not Is_Entity_Name (Node (Discr_Val)) + or else + Ekind (Entity (Node (Discr_Val))) /= E_Discriminant + then + Comp_Expr := + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Occurrence_Of (Disc, Loc)); + + Instr := + Make_OK_Assignment_Statement (Loc, + Name => Comp_Expr, + Expression => New_Copy_Tree (Node (Discr_Val))); + + Set_No_Ctrl_Actions (Instr); + Append_To (L, Instr); + end if; + + Next_Discriminant (Disc); + Next_Elmt (Discr_Val); + end loop; + + Btype := Base_Type (Parent_Type); + end loop; + end; + + -- Generate discriminant init values for the visible discriminants declare Discriminant : Entity_Id; @@ -2461,9 +2547,111 @@ package body Exp_Aggr is -- inner aggregate top-down. if Is_Delayed_Aggregate (Expr_Q) then - Append_List_To (L, - Late_Expansion (Expr_Q, Comp_Type, Comp_Expr, - Internal_Final_List)); + + -- We have the following case of aggregate nesting inside + -- an object declaration: + + -- type Arr_Typ is array (Integer range <>) of ...; + -- + -- type Rec_Typ (...) is record + -- Obj_Arr_Typ : Arr_Typ (A .. B); + -- end record; + -- + -- Obj_Rec_Typ : Rec_Typ := (..., + -- Obj_Arr_Typ => (X => (...), Y => (...))); + + -- The length of the ranges of the aggregate and Obj_Add_Typ + -- are equal (B - A = Y - X), but they do not coincide (X /= + -- A and B /= Y). This case requires array sliding which is + -- performed in the following manner: + + -- subtype Arr_Sub is Arr_Typ (X .. Y); + -- Temp : Arr_Sub; + -- Temp (X) := (...); + -- ... + -- Temp (Y) := (...); + -- Obj_Rec_Typ.Obj_Arr_Typ := Temp; + + if Present (Obj) + and then Ekind (Comp_Type) = E_Array_Subtype + and then Is_Int_Range_Bounds (Aggregate_Bounds (Expr_Q)) + and then Is_Int_Range_Bounds (First_Index (Comp_Type)) + and then not + Compatible_Int_Bounds ( + Agg_Bounds => Aggregate_Bounds (Expr_Q), + Typ_Bounds => First_Index (Comp_Type)) + then + declare + -- Create the array subtype with bounds equal to those + -- of the corresponding aggregate. + + SubE : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('T')); + + SubD : constant Node_Id := + Make_Subtype_Declaration (Loc, + Defining_Identifier => + SubE, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To ( + Etype (Comp_Type), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint ( + Loc, Constraints => New_List ( + New_Copy_Tree (Aggregate_Bounds ( + Expr_Q)))))); + + -- Create a temporary array of the above subtype which + -- will be used to capture the aggregate assignments. + + TmpE : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('A')); + + TmpD : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => + TmpE, + Object_Definition => + New_Reference_To (SubE, Loc)); + + begin + Set_No_Initialization (TmpD); + Append_To (L, SubD); + Append_To (L, TmpD); + + -- Expand the aggregate into assignments to the temporary + -- array. + + Append_List_To (L, + Late_Expansion (Expr_Q, Comp_Type, + New_Reference_To (TmpE, Loc), Internal_Final_List)); + + -- Slide + + Append_To (L, + Make_Assignment_Statement (Loc, + Name => New_Copy_Tree (Comp_Expr), + Expression => New_Reference_To (TmpE, Loc))); + + -- Do not pass the original aggregate to Gigi as is + -- since it will potentially clobber the front or the + -- end of the array. Setting the expression to empty + -- is safe since all aggregates will be expanded into + -- assignments. + + Set_Expression (Parent (Obj), Empty); + end; + + -- Normal case (sliding not required) + + else + Append_List_To (L, + Late_Expansion (Expr_Q, Comp_Type, Comp_Expr, + Internal_Final_List)); + end if; else Instr := -- 2.30.2