-- --
-- 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- --
-- 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
-- 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);
-- 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
-- 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
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));
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;
-- 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;
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
-- 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;
-- 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 --
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 --
--------------------------------
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 --
-------------------------------
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;
-- 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 :=
projects / gcc.git / commitdiff