exp_aggr.adb (Build_Array_Aggr_Code): Rename variable "Others_Mbox_Present" to "Others_Box_Present" because the mbox...
2006-02-13 Ed Schonberg <schonberg@adacore.com> * 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
This commit is contained in:
Ed Schonberg
Arnaud Charlet
parent
2c351f04f4
commit
d8f7b976d7
1 changed files with 212 additions and 24 deletions
|
|
@ -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;
|
||||
|
||||
-- Generate discriminant init values
|
||||
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
|
||||
|
||||
-- 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 :=
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue