-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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- --
type Case_Table_Type is array (Nat range <>) of Case_Bounds;
-- Table type used by Check_Case_Choices procedure
+ function Must_Slide
+ (Obj_Type : Entity_Id;
+ Typ : Entity_Id) return Boolean;
+ -- A static array aggregate in an object declaration can in most cases be
+ -- expanded in place. The one exception is when the aggregate is given
+ -- with component associations that specify different bounds from those of
+ -- the type definition in the object declaration. In this pathological
+ -- case the aggregate must slide, and we must introduce an intermediate
+ -- temporary to hold it.
+ --
+ -- The same holds in an assignment to one-dimensional array of arrays,
+ -- when a component may be given with bounds that differ from those of the
+ -- component type.
+
procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
-- Sort the Case Table using the Lower Bound of each Choice as the key.
-- A simple insertion sort is used since the number of choices in a case
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty;
Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id;
- -- N is an N_Aggregate or a N_Extension_Aggregate. Typ is the type
- -- of the aggregate. Target is an expression containing the
- -- location on which the component by component assignments will
- -- take place. Returns the list of assignments plus all other
- -- adjustments needed for tagged and controlled types. Flist is an
- -- expression representing the finalization list on which to
- -- attach the controlled components if any. Obj is present in the
- -- object declaration and dynamic allocation cases, it contains
- -- an entity that allows to know if the value being created needs to be
- -- attached to the final list in case of pragma finalize_Storage_Only.
+ -- N is an N_Aggregate or a N_Extension_Aggregate. Typ is the type of the
+ -- aggregate. Target is an expression containing the location on which the
+ -- component by component assignments will take place. Returns the list of
+ -- assignments plus all other adjustments needed for tagged and controlled
+ -- types. Flist is an expression representing the finalization list on
+ -- which to attach the controlled components if any. Obj is present in the
+ -- object declaration and dynamic allocation cases, it contains an entity
+ -- that allows to know if the value being created needs to be attached to
+ -- the final list in case of pragma finalize_Storage_Only.
+ --
-- Is_Limited_Ancestor_Expansion indicates that the function has been
-- called recursively to expand the limited ancestor to avoid copying it.
Max_Others_Replicate : Nat := 5;
Handle_Bit_Packed : Boolean := False);
-- If possible, convert named notation to positional notation. This
- -- conversion is possible only in some static cases. If the conversion
- -- is possible, then N is rewritten with the analyzed converted
- -- aggregate. The parameter Max_Others_Replicate controls the maximum
- -- number of values corresponding to an others choice that will be
- -- converted to positional notation (the default of 5 is the normal
- -- limit, and reflects the fact that normally the loop is better than
- -- a lot of separate assignments). Note that this limit gets overridden
- -- in any case if either of the restrictions No_Elaboration_Code or
- -- No_Implicit_Loops is set. The parameter Handle_Bit_Packed is usually
- -- set False (since we do not expect the back end to handle bit packed
- -- arrays, so the normal case of conversion is pointless), but in the
- -- special case of a call from Packed_Array_Aggregate_Handled, we set
- -- this parameter to True, since these are cases we handle in there.
+ -- conversion is possible only in some static cases. If the conversion is
+ -- possible, then N is rewritten with the analyzed converted aggregate.
+ -- The parameter Max_Others_Replicate controls the maximum number of
+ -- values corresponding to an others choice that will be converted to
+ -- positional notation (the default of 5 is the normal limit, and reflects
+ -- the fact that normally the loop is better than a lot of separate
+ -- assignments). Note that this limit gets overridden in any case if
+ -- either of the restrictions No_Elaboration_Code or No_Implicit_Loops is
+ -- set. The parameter Handle_Bit_Packed is usually set False (since we do
+ -- not expect the back end to handle bit packed arrays, so the normal case
+ -- of conversion is pointless), but in the special case of a call from
+ -- Packed_Array_Aggregate_Handled, we set this parameter to True, since
+ -- these are cases we handle in there.
procedure Expand_Array_Aggregate (N : Node_Id);
-- This is the top-level routine to perform array aggregate expansion.
Target : Node_Id;
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty) return List_Id;
- -- N is a nested (record or array) aggregate that has been marked
- -- with 'Delay_Expansion'. Typ is the expected type of the
- -- aggregate and Target is a (duplicable) expression that will
- -- hold the result of the aggregate expansion. Flist is the
- -- finalization list to be used to attach controlled
- -- components. 'Obj' when non empty, carries the original object
- -- being initialized in order to know if it needs to be attached
- -- to the previous parameter which may not be the case when
- -- Finalize_Storage_Only is set. Basically this procedure is used
- -- to implement top-down expansions of nested aggregates. This is
- -- necessary for avoiding temporaries at each level as well as for
- -- propagating the right internal finalization list.
+ -- N is a nested (record or array) aggregate that has been marked with
+ -- 'Delay_Expansion'. Typ is the expected type of the aggregate and Target
+ -- is a (duplicable) expression that will hold the result of the aggregate
+ -- expansion. Flist is the finalization list to be used to attach
+ -- controlled components. 'Obj' when non empty, carries the original
+ -- object being initialized in order to know if it needs to be attached to
+ -- the previous parameter which may not be the case in the case where
+ -- Finalize_Storage_Only is set. Basically this procedure is used to
+ -- implement top-down expansions of nested aggregates. This is necessary
+ -- for avoiding temporaries at each level as well as for propagating the
+ -- right internal finalization list.
function Make_OK_Assignment_Statement
(Sloc : Source_Ptr;
function Backend_Processing_Possible (N : Node_Id) return Boolean is
Typ : constant Entity_Id := Etype (N);
- -- Typ is the correct constrained array subtype of the aggregate.
+ -- Typ is the correct constrained array subtype of the aggregate
function Static_Check (N : Node_Id; Index : Node_Id) return Boolean;
- -- Recursively checks that N is fully positional, returns true if so.
+ -- Recursively checks that N is fully positional, returns true if so
------------------
-- Static_Check --
end if;
-- Checks 5 (if the component type is tagged, then we may need
- -- to do tag adjustments; perhaps this should be refined to
- -- check for any component associations that actually
- -- need tag adjustment, along the lines of the test that's
- -- done in Has_Delayed_Nested_Aggregate_Or_Tagged_Comps
- -- for record aggregates with tagged components, but not
- -- clear whether it's worthwhile ???; in the case of the
- -- JVM, object tags are handled implicitly)
+ -- to do tag adjustments; perhaps this should be refined to check for
+ -- any component associations that actually need tag adjustment,
+ -- along the lines of the test that is carried out in
+ -- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps for record aggregates
+ -- with tagged components, but not clear whether it's worthwhile ???;
+ -- in the case of the JVM, object tags are handled implicitly)
if Is_Tagged_Type (Component_Type (Typ)) and then not Java_VM then
return False;
-- we are dealing with an expression we emit a sequence of
-- assignments instead of a loop.
- -- (c) Generate the remaining loops to cover the others choice if any.
+ -- (c) Generate the remaining loops to cover the others choice if any
-- 2. If the aggregate contains positional elements we
- -- (a) translate the positional elements in a series of assignments.
+ -- (a) translate the positional elements in a series of assignments
-- (b) Generate a final loop to cover the others choice if any.
-- Note that this final loop has to be a while loop since the case
Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base);
function Add (Val : Int; To : Node_Id) return Node_Id;
- -- Returns an expression where Val is added to expression To,
- -- unless To+Val is provably out of To's base type range.
- -- To must be an already analyzed expression.
+ -- Returns an expression where Val is added to expression To, unless
+ -- To+Val is provably out of To's base type range. To must be an
+ -- already analyzed expression.
function Empty_Range (L, H : Node_Id) return Boolean;
- -- Returns True if the range defined by L .. H is certainly empty.
+ -- Returns True if the range defined by L .. H is certainly empty
function Equal (L, H : Node_Id) return Boolean;
- -- Returns True if L = H for sure.
+ -- Returns True if L = H for sure
function Index_Base_Name return Node_Id;
- -- Returns a new reference to the index type name.
+ -- Returns a new reference to the index type name
function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id;
-- Ind must be a side-effect free expression. If the input aggregate
--
-- Into (Indices, Ind) := Expr;
--
- -- Otherwise we call Build_Code recursively.
+ -- Otherwise we call Build_Code recursively
--
-- Ada 2005 (AI-287): In case of default initialized component, Expr
-- is empty and we generate a call to the corresponding IP subprogram.
end if;
if Is_Delayed_Aggregate (Expr_Q) then
- return
- Add_Loop_Actions (
- Late_Expansion (Expr_Q, Etype (Expr_Q), Indexed_Comp, F));
+
+ -- This is either a subaggregate of a multidimentional array,
+ -- or a component of an array type whose component type is
+ -- also an array. In the latter case, the expression may have
+ -- component associations that provide different bounds from
+ -- those of the component type, and sliding must occur. Instead
+ -- of decomposing the current aggregate assignment, force the
+ -- re-analysis of the assignment, so that a temporary will be
+ -- generated in the usual fashion, and sliding will take place.
+
+ if Nkind (Parent (N)) = N_Assignment_Statement
+ and then Is_Array_Type (Comp_Type)
+ and then Present (Component_Associations (Expr_Q))
+ and then Must_Slide (Comp_Type, Etype (Expr_Q))
+ then
+ Set_Expansion_Delayed (Expr_Q, False);
+ Set_Analyzed (Expr_Q, False);
+
+ else
+ return
+ Add_Loop_Actions (
+ Late_Expansion (
+ Expr_Q, Etype (Expr_Q), Indexed_Comp, F));
+ end if;
end if;
end if;
Sort_Case_Table (Table);
end if;
- -- STEP 1 (b): take care of the whole set of discrete choices.
+ -- STEP 1 (b): take care of the whole set of discrete choices
for J in 1 .. Nb_Choices loop
Low := Table (J).Choice_Lo;
Next_Elmt (Disc2);
end loop;
- -- If any discriminant constraint is non-static, emit a check.
+ -- If any discriminant constraint is non-static, emit a check
if Present (Cond) then
Insert_Action (N,
(N : Node_Id;
Ix : Node_Id;
Ixb : Node_Id) return Boolean;
- -- Convert the aggregate into a purely positional form if possible.
+ -- Convert the aggregate into a purely positional form if possible
function Is_Flat (N : Node_Id; Dims : Int) return Boolean;
- -- Non trivial for multidimensional aggregate.
+ -- Return True iff the array N is flat (which is not rivial
+ -- in the case of multidimensionsl aggregates).
-------------
-- Flatten --
-- Ctyp is the corresponding component type.
Aggr_Dimension : constant Pos := Number_Dimensions (Typ);
- -- Number of aggregate index dimensions.
+ -- Number of aggregate index dimensions
Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id;
Aggr_High : array (1 .. Aggr_Dimension) of Node_Id;
- -- Low and High bounds of the constraint for each aggregate index.
+ -- Low and High bounds of the constraint for each aggregate index
Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id;
- -- The type of each index.
+ -- The type of each index
Maybe_In_Place_OK : Boolean;
-- If the type is neither controlled nor packed and the aggregate
-- be done in place, because none of the new values can depend on the
-- components of the target of the assignment.
- function Must_Slide (N : Node_Id; Typ : Entity_Id) return Boolean;
- -- A static aggregate in an object declaration can in most cases be
- -- expanded in place. The one exception is when the aggregate is given
- -- with component associations that specify different bounds from those
- -- of the type definition in the object declaration. In this rather
- -- pathological case the aggregate must slide, and we must introduce
- -- an intermediate temporary to hold it.
-
procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos);
-- Checks that if an others choice is present in any sub-aggregate no
-- aggregate index is outside the bounds of the index constraint.
procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is
Sub_Lo : constant Node_Id := Low_Bound (Aggregate_Bounds (Sub_Aggr));
Sub_Hi : constant Node_Id := High_Bound (Aggregate_Bounds (Sub_Aggr));
- -- The bounds of this specific sub-aggregate.
+ -- The bounds of this specific sub-aggregate
Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
Aggr_Hi : constant Node_Id := Aggr_High (Dim);
-- The bounds of the aggregate for this dimension
Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
- -- The index type for this dimension.
+ -- The index type for this dimension.xxx
Cond : Node_Id := Empty;
Comp : Node_Id := Expr;
function Check_Component (Comp : Node_Id) return Boolean;
- -- Do the recursive traversal, after copy.
+ -- Do the recursive traversal, after copy
---------------------
-- Check_Component --
return False;
elsif Nkind (Expr) = N_Allocator then
- -- For now, too complex to analyze.
+
+ -- For now, too complex to analyze
return False;
end if;
end loop;
end if;
- -- Now check the component values themselves.
+ -- Now check the component values themselves
return Safe_Aggregate (N);
end In_Place_Assign_OK;
- ----------------
- -- Must_Slide --
- ----------------
-
- function Must_Slide (N : Node_Id; Typ : Entity_Id) return Boolean
- is
- Obj_Type : constant Entity_Id :=
- Etype (Defining_Identifier (Parent (N)));
-
- L1, L2, H1, H2 : Node_Id;
-
- begin
- -- No sliding if the type of the object is not established yet, if
- -- it is an unconstrained type whose actual subtype comes from the
- -- aggregate, or if the two types are identical.
-
- if not Is_Array_Type (Obj_Type) then
- return False;
-
- elsif not Is_Constrained (Obj_Type) then
- return False;
-
- elsif Typ = Obj_Type then
- return False;
-
- else
- -- Sliding can only occur along the first dimension
-
- Get_Index_Bounds (First_Index (Typ), L1, H1);
- Get_Index_Bounds (First_Index (Obj_Type), L2, H2);
-
- if not Is_Static_Expression (L1)
- or else not Is_Static_Expression (L2)
- or else not Is_Static_Expression (H1)
- or else not Is_Static_Expression (H2)
- then
- return False;
- else
- return Expr_Value (L1) /= Expr_Value (L2)
- or else Expr_Value (H1) /= Expr_Value (H2);
- end if;
- end if;
- end Must_Slide;
-
------------------
-- Others_Check --
------------------
procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos) is
Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
Aggr_Hi : constant Node_Id := Aggr_High (Dim);
- -- The bounds of the aggregate for this dimension.
+ -- The bounds of the aggregate for this dimension
Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
- -- The index type for this dimension.
+ -- The index type for this dimension
Need_To_Check : Boolean := False;
pragma Assert (not Raises_Constraint_Error (N));
- -- STEP 1a.
+ -- STEP 1a
-- Check that the index range defined by aggregate bounds is
-- compatible with corresponding index subtype.
end loop;
end Index_Compatibility_Check;
- -- STEP 1b.
+ -- STEP 1b
-- If an others choice is present check that no aggregate
-- index is outside the bounds of the index constraint.
Others_Check (N, 1);
- -- STEP 1c.
+ -- STEP 1c
-- For multidimensional arrays make sure that all subaggregates
-- corresponding to the same dimension have the same bounds.
Check_Same_Aggr_Bounds (N, 1);
end if;
- -- STEP 2.
+ -- STEP 2
-- Here we test for is packed array aggregate that we can handle
-- at compile time. If so, return with transformation done. Note
return;
end if;
- -- STEP 3.
+ -- STEP 3
-- Delay expansion for nested aggregates it will be taken care of
-- when the parent aggregate is expanded
return;
end if;
- -- STEP 4.
+ -- STEP 4
-- Look if in place aggregate expansion is possible
if not Has_Default_Init_Comps (N)
and then Comes_From_Source (Parent (N))
and then Nkind (Parent (N)) = N_Object_Declaration
- and then not Must_Slide (N, Typ)
+ and then not
+ Must_Slide (Etype (Defining_Identifier (Parent (N))), Typ)
and then N = Expression (Parent (N))
and then not Is_Bit_Packed_Array (Typ)
and then not Has_Controlled_Component (Typ)
Set_Expansion_Delayed (N);
return;
- -- In the remaining cases the aggregate is the RHS of an assignment.
+ -- In the remaining cases the aggregate is the RHS of an assignment
elsif Maybe_In_Place_OK
and then Is_Entity_Name (Name (Parent (N)))
if Is_Tagged_Type (Typ) then
- -- The tagged case, _parent and _tag component must be created.
+ -- The tagged case, _parent and _tag component must be created
-- Reset null_present unconditionally. tagged records always have
-- at least one field (the tag or the parent)
end if;
end Initialize_Discriminants;
+ ----------------
+ -- Must_Slide --
+ ----------------
+
+ function Must_Slide
+ (Obj_Type : Entity_Id;
+ Typ : Entity_Id) return Boolean
+ is
+ L1, L2, H1, H2 : Node_Id;
+ begin
+ -- No sliding if the type of the object is not established yet, if
+ -- it is an unconstrained type whose actual subtype comes from the
+ -- aggregate, or if the two types are identical.
+
+ if not Is_Array_Type (Obj_Type) then
+ return False;
+
+ elsif not Is_Constrained (Obj_Type) then
+ return False;
+
+ elsif Typ = Obj_Type then
+ return False;
+
+ else
+ -- Sliding can only occur along the first dimension
+
+ Get_Index_Bounds (First_Index (Typ), L1, H1);
+ Get_Index_Bounds (First_Index (Obj_Type), L2, H2);
+
+ if not Is_Static_Expression (L1)
+ or else not Is_Static_Expression (L2)
+ or else not Is_Static_Expression (H1)
+ or else not Is_Static_Expression (H2)
+ then
+ return False;
+ else
+ return Expr_Value (L1) /= Expr_Value (L2)
+ or else Expr_Value (H1) /= Expr_Value (H2);
+ end if;
+ end if;
+ end Must_Slide;
+
---------------------------
-- Safe_Slice_Assignment --
---------------------------
projects / gcc.git / commitdiff