Skip to content

R
riscv-gcc-1
Commit 0f95b178 by Javier Miranda Committed by Arnaud Charlet
Options

exp_aggr.ads, [...]: 

2007-04-20  Javier Miranda  <miranda@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Bob Duff  <duff@adacore.com>
	    Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_aggr.ads, exp_aggr.adb: 
	(Build_Record_Aggr_Code): Add missing initialization of secondary tags
	in extension aggregates.
	(Flatten): Other conditions being met, an aggregate is static if the
	low bound given by component associations is different from the low
	bound of the base index type.
	(Packed_Array_Aggregate_Handled): If the component type is itself a
	packed array or record, the front-end must expand into assignments.
	(Gen_Ctrl_Actions_For_Aggr): In call to Init_Controller, pass False to
	Init_Pr, instead of Ancestor_Is_Expression.
	(Gen_Ctrl_Actions_For_Aggr): When processing an aggregate of a
	coextension chain root, either generate a list controller or use the
	already existing one.
	(Static_Array_Aggregate): New procedure to construct a positional
	aggregate that can be handled by the backend, when all bounds and
	components are compile-time known constants.
	(Expand_Record_Aggregate): Force conversion of aggregates of tagged
	types covering interface types into assignments.
	(Replace_Type): move to Build_Record_Aggr_Code.
	(Expand_Record_Aggr_Code): if the target of the aggregate is an
	interface type, convert to the definite type of the aggregate itself,
	so that needed components are visible.
	(Convert_Aggr_In_Object_Decl): If the aggregate has controlled
	components and the context is an extended return statement do not
	create a transient block for it, to prevent premature finalization
	before the return is executed.
	(Gen_Assign): Do not generate a call to deep adjust routine if the
	component type is itself an array of controlled (sub)-components
	initialized with an inner aggregate.
	(Component_Check): New name for Static_Check. This name is now more
	appropriate, and documentation is added which was missing.
	(Component_Check): Add test for bit aligned component value
	(Component_Not_OK_For_Backend): Renames Has_Delayed_Nested_Aggregate_Or_
	Tagged_Comps, name is more appropriate given added function below.
	(Component_Not_OK_For_Backend): Check for bit aligned component ref.

From-SVN: r125392
parent 1c28fe3a
Showing with 605 additions and 165 deletions
gcc/ada/exp_aggr.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
......@@ -36,9 +36,9 @@ with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
with Exp_Tss; use Exp_Tss;
with Freeze; use Freeze;
with Hostparm; use Hostparm;
with Itypes; use Itypes;
with Lib; use Lib;
with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
......@@ -54,6 +54,7 @@ with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
......@@ -121,7 +122,7 @@ package body Exp_Aggr is
function Build_Record_Aggr_Code
(N : Node_Id;
Typ : Entity_Id;
Target : Node_Id;
Lhs : Node_Id;
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty;
Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id;
......@@ -262,17 +263,11 @@ package body Exp_Aggr is
function Make_OK_Assignment_Statement
(Sloc : Source_Ptr;
Name : Node_Id;
Expression : Node_Id;
Self_Ref : Boolean := False) return Node_Id;
Expression : Node_Id) return Node_Id;
-- This is like Make_Assignment_Statement, except that Assignment_OK
-- is set in the left operand. All assignments built by this unit
-- use this routine. This is needed to deal with assignments to
-- initialized constants that are done in place.
-- If Self_Ref is true, the aggregate contains an access reference to the
-- enclosing type, obtained from a default initialization. The reference
-- as to be expanded into a reference to the enclosing object, which is
-- obtained from the Name in the assignment. The value of Self_Ref is
-- inherited from the aggregate itself.
function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;
-- Given an array aggregate, this function handles the case of a packed
......@@ -451,32 +446,46 @@ package body Exp_Aggr is
-- 4. The array type of N does not follow the Fortran layout convention
-- or if it does it must be 1 dimensional.
-- 5. The array component type is tagged, which may necessitate
-- reassignment of proper tags.
-- 5. The array component type may not be tagged (which could necessitate
-- reassignment of proper tags).
-- 6. The array component type might have unaligned bit components
-- 6. The array component type must not have unaligned bit components
-- 7. None of the components of the aggregate may be bit unaligned
-- components.
-- 8. There cannot be delayed components, since we do not know enough
-- at this stage to know if back end processing is possible.
-- 9. There cannot be any discriminated record components, since the
-- back end cannot handle this complex case.
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
function Static_Check (N : Node_Id; Index : Node_Id) return Boolean;
-- Recursively checks that N is fully positional, returns true if so
function Component_Check (N : Node_Id; Index : Node_Id) return Boolean;
-- This routine checks components of aggregate N, enforcing checks
-- 1, 7, 8, and 9. In the multi-dimensional case, these checks are
-- performed on subaggregates. The Index value is the current index
-- being checked in the multi-dimensional case.
------------------
-- Static_Check --
------------------
---------------------
-- Component_Check --
---------------------
function Static_Check (N : Node_Id; Index : Node_Id) return Boolean is
function Component_Check (N : Node_Id; Index : Node_Id) return Boolean is
Expr : Node_Id;
begin
-- Check for component associations
-- Checks 1: (no component associations)
if Present (Component_Associations (N)) then
return False;
end if;
-- Checks on components
-- Recurse to check subaggregates, which may appear in qualified
-- expressions. If delayed, the front-end will have to expand.
-- If the component is a discriminated record, treat as non-static,
......@@ -484,10 +493,15 @@ package body Exp_Aggr is
Expr := First (Expressions (N));
while Present (Expr) loop
-- Checks 8: (no delayed components)
if Is_Delayed_Aggregate (Expr) then
return False;
end if;
-- Checks 9: (no discriminated records)
if Present (Etype (Expr))
and then Is_Record_Type (Etype (Expr))
and then Has_Discriminants (Etype (Expr))
......@@ -495,17 +509,27 @@ package body Exp_Aggr is
return False;
end if;
-- Checks 7. Component must not be bit aligned component
if Possible_Bit_Aligned_Component (Expr) then
return False;
end if;
-- Recursion to following indexes for multiple dimension case
if Present (Next_Index (Index))
and then not Static_Check (Expr, Next_Index (Index))
and then not Component_Check (Expr, Next_Index (Index))
then
return False;
end if;
-- All checks for that component finished, on to next
Next (Expr);
end loop;
return True;
end Static_Check;
end Component_Check;
-- Start of processing for Backend_Processing_Possible
......@@ -530,21 +554,20 @@ package body Exp_Aggr is
return False;
end if;
-- Checks 1 (aggregate must be fully positional)
-- Checks on components
if not Static_Check (N, First_Index (Typ)) then
if not Component_Check (N, First_Index (Typ)) then
return False;
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 is carried out in
-- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps for record aggregates
-- 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, similar
-- to the test in Component_Not_OK_For_Backend 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
if Is_Tagged_Type (Component_Type (Typ)) and then VM_Target = No_VM then
return False;
end if;
......@@ -556,7 +579,6 @@ package body Exp_Aggr is
-- Backend processing is possible
Set_Compile_Time_Known_Aggregate (N, True);
Set_Size_Known_At_Compile_Time (Etype (N), True);
return True;
end Backend_Processing_Possible;
......@@ -1094,7 +1116,7 @@ package body Exp_Aggr is
if Present (Comp_Type)
and then Is_Tagged_Type (Comp_Type)
and then not Java_VM
and then VM_Target = No_VM
then
A :=
Make_OK_Assignment_Statement (Loc,
......@@ -1114,11 +1136,24 @@ package body Exp_Aggr is
Append_To (L, A);
end if;
-- Adjust and Attach the component to the proper final list
-- which can be the controller of the outer record object or
-- the final list associated with the scope
-- Adjust and attach the component to the proper final list, which
-- can be the controller of the outer record object or the final
-- list associated with the scope.
if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
-- If the component is itself an array of controlled types, whose
-- value is given by a sub-aggregate, then the attach calls have
-- been generated when individual subcomponent are assigned, and
-- and must not be done again to prevent malformed finalization
-- chains (see comments above, concerning the creation of a block
-- to hold inner finalization actions).
if Present (Comp_Type)
and then Controlled_Type (Comp_Type)
and then
(not Is_Array_Type (Comp_Type)
or else not Is_Controlled (Component_Type (Comp_Type))
or else Nkind (Expr) /= N_Aggregate)
then
Append_List_To (L,
Make_Adjust_Call (
Ref => New_Copy_Tree (Indexed_Comp),
......@@ -1253,7 +1288,17 @@ package body Exp_Aggr is
Iteration_Scheme => L_Iteration_Scheme,
Statements => L_Body));
return S;
-- A small optimization: if the aggregate is initialized with a
-- box and the component type has no initialization procedure,
-- remove the useless empty loop.
if Nkind (First (S)) = N_Loop_Statement
and then Is_Empty_List (Statements (First (S)))
then
return New_List (Make_Null_Statement (Loc));
else
return S;
end if;
end Gen_Loop;
---------------
......@@ -1605,7 +1650,7 @@ package body Exp_Aggr is
function Build_Record_Aggr_Code
(N : Node_Id;
Typ : Entity_Id;
Target : Node_Id;
Lhs : Node_Id;
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty;
Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id
......@@ -1617,6 +1662,7 @@ package body Exp_Aggr is
Comp : Node_Id;
Instr : Node_Id;
Ref : Node_Id;
Target : Entity_Id;
F : Node_Id;
Comp_Type : Entity_Id;
Selector : Entity_Id;
......@@ -1639,7 +1685,8 @@ package body Exp_Aggr is
Attach : Node_Id;
Ctrl_Stuff_Done : Boolean := False;
-- Could use comments here ???
-- True if Gen_Ctrl_Actions_For_Aggr has already been called; calls
-- after the first do nothing.
function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id;
-- Returns the value that the given discriminant of an ancestor
......@@ -1659,8 +1706,8 @@ package body Exp_Aggr is
-- assumed that both bounds are integer ranges.
procedure Gen_Ctrl_Actions_For_Aggr;
-- Deal with the various controlled type data structure
-- initializations.
-- Deal with the various controlled type data structure initializations
-- (but only if it hasn't been done already).
function Get_Constraint_Association (T : Entity_Id) return Node_Id;
-- Returns the first discriminant association in the constraint
......@@ -1672,10 +1719,10 @@ package body Exp_Aggr is
F : Node_Id;
Attach : Node_Id;
Init_Pr : Boolean) return List_Id;
-- returns the list of statements necessary to initialize the internal
-- controller of the (possible) ancestor typ into target and attach
-- it to finalization list F. Init_Pr conditions the call to the
-- init proc since it may already be done due to ancestor initialization
-- Returns the list of statements necessary to initialize the internal
-- controller of the (possible) ancestor typ into target and attach it
-- to finalization list F. Init_Pr conditions the call to the init proc
-- since it may already be done due to ancestor initialization.
function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean;
-- Check whether Bounds is a range node and its lower and higher bounds
......@@ -1880,7 +1927,7 @@ package body Exp_Aggr is
end Get_Constraint_Association;
---------------------
-- Init_controller --
-- Init_Controller --
---------------------
function Init_Controller
......@@ -1972,24 +2019,32 @@ package body Exp_Aggr is
-------------------------------
procedure Gen_Ctrl_Actions_For_Aggr is
Alloc : Node_Id := Empty;
begin
if not Ctrl_Stuff_Done then
Ctrl_Stuff_Done := True;
else
-- Do the work only the first time this is called
if Ctrl_Stuff_Done then
return;
end if;
Ctrl_Stuff_Done := True;
if Present (Obj)
and then Finalize_Storage_Only (Typ)
and then (Is_Library_Level_Entity (Obj)
or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) =
Standard_True)
and then Finalize_Storage_Only (Typ)
and then
(Is_Library_Level_Entity (Obj)
or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) =
Standard_True)
-- why not Is_True (Expr_Value (RTE (RE_Garbaage_Collected) ???
then
Attach := Make_Integer_Literal (Loc, 0);
elsif Nkind (Parent (N)) = N_Qualified_Expression
and then Nkind (Parent (Parent (N))) = N_Allocator
then
Alloc := Parent (Parent (N));
Attach := Make_Integer_Literal (Loc, 2);
else
......@@ -2003,19 +2058,37 @@ package body Exp_Aggr is
-- potentially transient current scope.
if Controlled_Type (Typ) then
if Present (Flist) then
-- The current aggregate belongs to an allocator which acts as
-- the root of a coextension chain.
if Present (Alloc)
and then Is_Coextension_Root (Alloc)
then
if No (Associated_Final_Chain (Etype (Alloc))) then
Build_Final_List (Alloc, Etype (Alloc));
end if;
External_Final_List :=
Make_Selected_Component (Loc,
Prefix =>
New_Reference_To (
Associated_Final_Chain (Etype (Alloc)), Loc),
Selector_Name =>
Make_Identifier (Loc, Name_F));
elsif Present (Flist) then
External_Final_List := New_Copy_Tree (Flist);
elsif Is_Entity_Name (Target)
and then Present (Scope (Entity (Target)))
then
External_Final_List
:= Find_Final_List (Scope (Entity (Target)));
External_Final_List :=
Find_Final_List (Scope (Entity (Target)));
else
External_Final_List := Find_Final_List (Current_Scope);
end if;
else
External_Final_List := Empty;
end if;
......@@ -2037,11 +2110,26 @@ package body Exp_Aggr is
if not Has_Controlled_Component (Typ) then
Ref := New_Copy_Tree (Target);
Set_Assignment_OK (Ref);
Append_To (L,
Make_Attach_Call (
Obj_Ref => Ref,
Flist_Ref => New_Copy_Tree (External_Final_List),
With_Attach => Attach));
-- This is an aggregate of a coextension. Do not produce a
-- finalization call, but rather attach the reference of the
-- aggregate to its coextension chain.
if Present (Alloc)
and then Is_Coextension (Alloc)
then
if No (Coextensions (Alloc)) then
Set_Coextensions (Alloc, New_Elmt_List);
end if;
Append_Elmt (Ref, Coextensions (Alloc));
else
Append_To (L,
Make_Attach_Call (
Obj_Ref => Ref,
Flist_Ref => New_Copy_Tree (External_Final_List),
With_Attach => Attach));
end if;
end if;
end if;
......@@ -2162,21 +2250,83 @@ package body Exp_Aggr is
Typ => Init_Typ,
F => F,
Attach => Attach,
Init_Pr => Ancestor_Is_Expression));
Init_Pr => False));
-- Note: Init_Pr is False because the ancestor part has
-- already been initialized either way (by default, if
-- given by a type name, otherwise from the expression).
end if;
end;
end if;
end Gen_Ctrl_Actions_For_Aggr;
function Replace_Type (Expr : Node_Id) return Traverse_Result;
-- If the aggregate contains a self-reference, traverse each
-- expression to replace a possible self-reference with a reference
-- to the proper component of the target of the assignment.
------------------
-- Replace_Type --
------------------
function Replace_Type (Expr : Node_Id) return Traverse_Result is
begin
if Nkind (Expr) = N_Attribute_Reference
and then Is_Entity_Name (Prefix (Expr))
and then Is_Type (Entity (Prefix (Expr)))
then
if Is_Entity_Name (Lhs) then
Rewrite (Prefix (Expr),
New_Occurrence_Of (Entity (Lhs), Loc));
elsif Nkind (Lhs) = N_Selected_Component then
Rewrite (Expr,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unrestricted_Access,
Prefix => New_Copy_Tree (Prefix (Lhs))));
Set_Analyzed (Parent (Expr), False);
else
Rewrite (Expr,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unrestricted_Access,
Prefix => New_Copy_Tree (Lhs)));
Set_Analyzed (Parent (Expr), False);
end if;
end if;
return OK;
end Replace_Type;
procedure Replace_Self_Reference is
new Traverse_Proc (Replace_Type);
-- Start of processing for Build_Record_Aggr_Code
begin
if Has_Self_Reference (N) then
Replace_Self_Reference (N);
end if;
-- If the target of the aggregate is class-wide, we must convert it
-- to the actual type of the aggregate, so that the proper components
-- are visible. We know already that the types are compatible.
if Present (Etype (Lhs))
and then Is_Interface (Etype (Lhs))
then
Target := Unchecked_Convert_To (Typ, Lhs);
else
Target := Lhs;
end if;
-- Deal with the ancestor part of extension aggregates
-- or with the discriminants of the root type
if Nkind (N) = N_Extension_Aggregate then
declare
A : constant Node_Id := Ancestor_Part (N);
A : constant Node_Id := Ancestor_Part (N);
Assign : List_Id;
begin
......@@ -2280,7 +2430,7 @@ package body Exp_Aggr is
Build_Record_Aggr_Code (
N => Unqualify (A),
Typ => Etype (Unqualify (A)),
Target => Target,
Lhs => Target,
Flist => Flist,
Obj => Obj,
Is_Limited_Ancestor_Expansion => True));
......@@ -2316,15 +2466,14 @@ package body Exp_Aggr is
Assign := New_List (
Make_OK_Assignment_Statement (Loc,
Name => Ref,
Expression => A,
Self_Ref => Has_Self_Reference (N)));
Expression => A));
Set_No_Ctrl_Actions (First (Assign));
-- Assign the tag now to make sure that the dispatching call in
-- the subsequent deep_adjust works properly (unless Java_VM,
-- the subsequent deep_adjust works properly (unless VM_Target,
-- where tags are implicit).
if not Java_VM then
if VM_Target = No_VM then
Instr :=
Make_OK_Assignment_Statement (Loc,
Name =>
......@@ -2343,6 +2492,20 @@ package body Exp_Aggr is
Set_Assignment_OK (Name (Instr));
Append_To (Assign, Instr);
-- Ada 2005 (AI-251): If tagged type has progenitors we must
-- also initialize tags of the secondary dispatch tables.
if Present (Abstract_Interfaces (Base_Type (Typ)))
and then not
Is_Empty_Elmt_List
(Abstract_Interfaces (Base_Type (Typ)))
then
Init_Secondary_Tags
(Typ => Base_Type (Typ),
Target => Target,
Stmts_List => Assign);
end if;
end if;
-- Call Adjust manually
......@@ -2690,19 +2853,18 @@ package body Exp_Aggr is
Instr :=
Make_OK_Assignment_Statement (Loc,
Name => Comp_Expr,
Expression => Expression (Comp),
Self_Ref => Has_Self_Reference (N));
Expression => Expression (Comp));
Set_No_Ctrl_Actions (Instr);
Append_To (L, Instr);
-- Adjust the tag if tagged (because of possible view
-- conversions), unless compiling for the Java VM
-- where tags are implicit.
-- conversions), unless compiling for a VM where tags are
-- implicit.
-- tmp.comp._tag := comp_typ'tag;
if Is_Tagged_Type (Comp_Type) and then not Java_VM then
if Is_Tagged_Type (Comp_Type) and then VM_Target = No_VM then
Instr :=
Make_OK_Assignment_Statement (Loc,
Name =>
......@@ -2762,13 +2924,45 @@ package body Exp_Aggr is
pragma Assert (Present (D_Val));
Append_To (L,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd => New_Copy_Tree (Node (D_Val)),
Right_Opnd => Expression (Comp)),
Reason => CE_Discriminant_Check_Failed));
-- This check cannot performed for components that are
-- constrained by a current instance, because this is not a
-- value that can be compared with the actual constraint.
if Nkind (Node (D_Val)) /= N_Attribute_Reference
or else not Is_Entity_Name (Prefix (Node (D_Val)))
or else not Is_Type (Entity (Prefix (Node (D_Val))))
then
Append_To (L,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd => New_Copy_Tree (Node (D_Val)),
Right_Opnd => Expression (Comp)),
Reason => CE_Discriminant_Check_Failed));
else
-- Find self-reference in previous discriminant
-- assignment, and replace with proper expression.
declare
Ass : Node_Id;
begin
Ass := First (L);
while Present (Ass) loop
if Nkind (Ass) = N_Assignment_Statement
and then Nkind (Name (Ass)) = N_Selected_Component
and then Chars (Selector_Name (Name (Ass))) =
Chars (Disc)
then
Set_Expression
(Ass, New_Copy_Tree (Expression (Comp)));
exit;
end if;
Next (Ass);
end loop;
end;
end if;
end;
end if;
......@@ -2785,7 +2979,7 @@ package body Exp_Aggr is
if Ancestor_Is_Expression then
null;
elsif Is_Tagged_Type (Typ) and then not Java_VM then
elsif Is_Tagged_Type (Typ) and then VM_Target = No_VM then
Instr :=
Make_OK_Assignment_Statement (Loc,
Name =>
......@@ -2878,8 +3072,12 @@ package body Exp_Aggr is
-- ??? Dubious actual for Obj: expect 'the original object
-- being initialized'
Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts);
Insert_Actions_After (Decl, L);
if Has_Task (Typ) then
Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts);
Insert_Actions_After (Decl, L);
else
Insert_Actions_After (Decl, Init_Stmts);
end if;
end;
else
......@@ -3010,7 +3208,15 @@ package body Exp_Aggr is
return;
end if;
if Requires_Transient_Scope (Typ) then
-- If the context is an extended return statement, it has its own
-- finalization machinery (i.e. works like a transient scope) and
-- we do not want to create an additional one, because objects on
-- the finalization list of the return must be moved to the caller's
-- finalization list to complete the return.
if Requires_Transient_Scope (Typ)
and then Ekind (Current_Scope) /= E_Return_Statement
then
Establish_Transient_Scope (Aggr, Sec_Stack =>
Is_Controlled (Typ) or else Has_Controlled_Component (Typ));
end if;
......@@ -3088,15 +3294,22 @@ package body Exp_Aggr is
end if;
-- Just set the Delay flag in the following cases where the
-- transformation will be done top down from above
-- transformation will be done top down from above:
-- - internal aggregate (transformed when expanding the parent)
-- - allocators (see Convert_Aggr_In_Allocator)
-- - object decl (see Convert_Aggr_In_Object_Decl)
-- - safe assignments (see Convert_Aggr_Assignments)
-- so far only the assignments in the init procs are taken
-- into account
-- - (Ada 2005) A limited type in a return statement, which will
-- be rewritten as an extended return and may have its own
-- finalization machinery.
if Parent_Kind = N_Aggregate
or else Parent_Kind = N_Extension_Aggregate
or else Parent_Kind = N_Component_Association
......@@ -3104,6 +3317,10 @@ package body Exp_Aggr is
or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl)
or else (Parent_Kind = N_Assignment_Statement
and then Inside_Init_Proc)
or else
(Is_Limited_Record (Typ)
and then Present (Parent (Parent (N)))
and then Nkind (Parent (Parent (N))) = N_Return_Statement)
then
Set_Expansion_Delayed (N);
return;
......@@ -3144,6 +3361,13 @@ package body Exp_Aggr is
is
Typ : constant Entity_Id := Etype (N);
Static_Components : Boolean := True;
procedure Check_Static_Components;
-- Check whether all components of the aggregate are compile-time
-- known values, and can be passed as is to the back-end without
-- further expansion.
function Flatten
(N : Node_Id;
Ix : Node_Id;
......@@ -3156,6 +3380,56 @@ package body Exp_Aggr is
-- Return True iff the array N is flat (which is not rivial
-- in the case of multidimensionsl aggregates).
-----------------------------
-- Check_Static_Components --
-----------------------------
procedure Check_Static_Components is
Expr : Node_Id;
begin
Static_Components := True;
if Nkind (N) = N_String_Literal then
null;
elsif Present (Expressions (N)) then
Expr := First (Expressions (N));
while Present (Expr) loop
if Nkind (Expr) /= N_Aggregate
or else not Compile_Time_Known_Aggregate (Expr)
or else Expansion_Delayed (Expr)
then
Static_Components := False;
exit;
end if;
Next (Expr);
end loop;
end if;
if Nkind (N) = N_Aggregate
and then Present (Component_Associations (N))
then
Expr := First (Component_Associations (N));
while Present (Expr) loop
if Nkind (Expression (Expr)) = N_Integer_Literal then
null;
elsif Nkind (Expression (Expr)) /= N_Aggregate
or else
not Compile_Time_Known_Aggregate (Expression (Expr))
or else Expansion_Delayed (Expression (Expr))
then
Static_Components := False;
exit;
end if;
Next (Expr);
end loop;
end if;
end Check_Static_Components;
-------------
-- Flatten --
-------------
......@@ -3177,18 +3451,17 @@ package body Exp_Aggr is
return True;
end if;
-- Only handle bounds starting at the base type low bound
-- for now since the compiler isn't able to handle different low
-- bounds yet. Case such as new String'(3..5 => ' ') will get
-- the wrong bounds, though it seems that the aggregate should
-- retain the bounds set on its Etype (see C64103E and CC1311B).
if not Compile_Time_Known_Value (Lo)
or else not Compile_Time_Known_Value (Hi)
then
return False;
end if;
Lov := Expr_Value (Lo);
Hiv := Expr_Value (Hi);
if Hiv < Lov
or else not Compile_Time_Known_Value (Blo)
or else (Lov /= Expr_Value (Blo))
then
return False;
end if;
......@@ -3418,10 +3691,29 @@ package body Exp_Aggr is
return;
end if;
Check_Static_Components;
-- If the size is known, or all the components are static, try to
-- build a fully positional aggregate.
-- The size of the type may not be known for an aggregate with
-- discriminated array components, but if the components are static
-- it is still possible to verify statically that the length is
-- compatible with the upper bound of the type, and therefore it is
-- worth flattening such aggregates as well.
-- For now the back-end expands these aggregates into individual
-- assignments to the target anyway, but it is conceivable that
-- it will eventually be able to treat such aggregates statically???
if Aggr_Size_OK (Typ)
and then
Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ)))
and then Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ)))
then
if Static_Components then
Set_Compile_Time_Known_Aggregate (N);
Set_Expansion_Delayed (N, False);
end if;
Analyze_And_Resolve (N, Typ);
end if;
end Convert_To_Positional;
......@@ -4393,7 +4685,14 @@ package body Exp_Aggr is
-- At this point we try to convert to positional form
Convert_To_Positional (N);
if Ekind (Current_Scope) = E_Package
and then Static_Elaboration_Desired (Current_Scope)
then
Convert_To_Positional (N, Max_Others_Replicate => 100);
else
Convert_To_Positional (N);
end if;
-- if the result is no longer an aggregate (e.g. it may be a string
-- literal, or a temporary which has the needed value), then we are
......@@ -4411,6 +4710,14 @@ package body Exp_Aggr is
return;
end if;
-- If all aggregate components are compile-time known and
-- the aggregate has been flattened, nothing left to do.
if Compile_Time_Known_Aggregate (N) then
Set_Expansion_Delayed (N, False);
return;
end if;
-- Now see if back end processing is possible
if Backend_Processing_Possible (N) then
......@@ -4467,8 +4774,15 @@ package body Exp_Aggr is
or else (Parent_Kind = N_Assignment_Statement
and then Inside_Init_Proc)
then
Set_Expansion_Delayed (N);
return;
if Static_Array_Aggregate (N)
or else Compile_Time_Known_Aggregate (N)
then
Set_Expansion_Delayed (N, False);
return;
else
Set_Expansion_Delayed (N);
return;
end if;
end if;
-- STEP 4
......@@ -4682,7 +4996,6 @@ package body Exp_Aggr is
else
Expand_Array_Aggregate (N);
end if;
exception
when RE_Not_Available =>
return;
......@@ -4721,17 +5034,16 @@ package body Exp_Aggr is
else
Set_Etype (N, Typ);
-- No tag is needed in the case of Java_VM
if Java_VM then
Expand_Record_Aggregate (N,
Parent_Expr => A);
else
if VM_Target = No_VM then
Expand_Record_Aggregate (N,
Orig_Tag =>
New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc),
Parent_Expr => A);
else
-- No tag is needed in the case of a VM
Expand_Record_Aggregate (N,
Parent_Expr => A);
end if;
end if;
......@@ -4754,15 +5066,23 @@ package body Exp_Aggr is
Typ : constant Entity_Id := Etype (N);
Base_Typ : constant Entity_Id := Base_Type (Typ);
function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean;
-- Checks the presence of a nested aggregate which needs Late_Expansion
-- or the presence of tagged components which may need tag adjustment.
Static_Components : Boolean := True;
-- Flag to indicate whether all components are compile-time known,
-- and the aggregate can be constructed statically and handled by
-- the back-end.
--------------------------------------------------
-- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps --
--------------------------------------------------
function Component_Not_OK_For_Backend return Boolean;
-- Check for presence of component which makes it impossible for the
-- backend to process the aggregate, thus requiring the use of a series
-- of assignment statements. Cases checked for are a nested aggregate
-- needing Late_Expansion, the presence of a tagged component which may
-- need tag adjustment, and a bit unaligned component reference.
function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean is
----------------------------------
-- Component_Not_OK_For_Backend --
----------------------------------
function Component_Not_OK_For_Backend return Boolean is
C : Node_Id;
Expr_Q : Node_Id;
......@@ -4784,27 +5104,44 @@ package body Exp_Aggr is
-- These are cases where the source expression may have
-- a tag that could differ from the component tag (e.g.,
-- can occur for type conversions and formal parameters).
-- (Tag adjustment is not needed if Java_VM because object
-- (Tag adjustment is not needed if VM_Target because object
-- tags are implicit in the JVM.)
if Is_Tagged_Type (Etype (Expr_Q))
and then (Nkind (Expr_Q) = N_Type_Conversion
or else (Is_Entity_Name (Expr_Q)
and then Ekind (Entity (Expr_Q)) in Formal_Kind))
and then not Java_VM
or else (Is_Entity_Name (Expr_Q)
and then
Ekind (Entity (Expr_Q)) in Formal_Kind))
and then VM_Target = No_VM
then
Static_Components := False;
return True;
end if;
if Is_Delayed_Aggregate (Expr_Q) then
elsif Is_Delayed_Aggregate (Expr_Q) then
Static_Components := False;
return True;
elsif Possible_Bit_Aligned_Component (Expr_Q) then
Static_Components := False;
return True;
end if;
if Is_Scalar_Type (Etype (Expr_Q)) then
if not Compile_Time_Known_Value (Expr_Q) then
Static_Components := False;
end if;
elsif Nkind (Expr_Q) /= N_Aggregate
or else not Compile_Time_Known_Aggregate (Expr_Q)
then
Static_Components := False;
end if;
Next (C);
end loop;
return False;
end Has_Delayed_Nested_Aggregate_Or_Tagged_Comps;
end Component_Not_OK_For_Backend;
-- Remaining Expand_Record_Aggregate variables
......@@ -4860,7 +5197,9 @@ package body Exp_Aggr is
elsif Has_Default_Init_Comps (N) then
Convert_To_Assignments (N, Typ);
elsif Has_Delayed_Nested_Aggregate_Or_Tagged_Comps then
-- Check components
elsif Component_Not_OK_For_Backend then
Convert_To_Assignments (N, Typ);
-- If an ancestor is private, some components are not inherited and
......@@ -4875,6 +5214,13 @@ package body Exp_Aggr is
elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then
Convert_To_Assignments (N, Typ);
-- If the tagged types covers interface types we need to initialize all
-- the hidden components containing the pointers to secondary dispatch
-- tables.
elsif Is_Tagged_Type (Typ) and then Has_Abstract_Interfaces (Typ) then
Convert_To_Assignments (N, Typ);
-- If some components are mutable, the size of the aggregate component
-- may be disctinct from the default size of the type component, so
-- we need to expand to insure that the back-end copies the proper
......@@ -4893,6 +5239,17 @@ package body Exp_Aggr is
-- can be handled by gigi.
else
if Nkind (N) = N_Aggregate then
-- If the aggregate is static and can be handled by the
-- back-end, nothing left to do.
if Static_Components then
Set_Compile_Time_Known_Aggregate (N);
Set_Expansion_Delayed (N, False);
end if;
end if;
-- If no discriminants, nothing special to do
if not Has_Discriminants (Typ) then
......@@ -5092,7 +5449,7 @@ package body Exp_Aggr is
if Present (Orig_Tag) then
Tag_Value := Orig_Tag;
elsif Java_VM then
elsif VM_Target /= No_VM then
Tag_Value := Empty;
else
Tag_Value :=
......@@ -5154,9 +5511,9 @@ package body Exp_Aggr is
end;
-- For a root type, the tag component is added (unless compiling
-- for the Java VM, where tags are implicit).
-- for the VMs, where tags are implicit).
elsif not Java_VM then
elsif VM_Target = No_VM then
declare
Tag_Name : constant Node_Id :=
New_Occurrence_Of
......@@ -5175,6 +5532,7 @@ package body Exp_Aggr is
end if;
end if;
end if;
end Expand_Record_Aggregate;
----------------------------
......@@ -5284,50 +5642,11 @@ package body Exp_Aggr is
function Make_OK_Assignment_Statement
(Sloc : Source_Ptr;
Name : Node_Id;
Expression : Node_Id;
Self_Ref : Boolean := False) return Node_Id
Expression : Node_Id) return Node_Id
is
function Replace_Type (Expr : Node_Id) return Traverse_Result;
-- If the aggregate contains a self-reference, traverse each
-- expression to replace a possible self-reference with a reference
-- to the proper component of the target of the assignment.
------------------
-- Replace_Type --
------------------
function Replace_Type (Expr : Node_Id) return Traverse_Result is
begin
if Nkind (Expr) = N_Attribute_Reference
and then Is_Entity_Name (Prefix (Expr))
and then Is_Type (Entity (Prefix (Expr)))
then
if Is_Entity_Name (Prefix (Name)) then
Rewrite (Prefix (Expr),
New_Occurrence_Of (Entity (Prefix (Name)), Sloc));
else
Rewrite (Expr,
Make_Attribute_Reference (Sloc,
Attribute_Name => Name_Unrestricted_Access,
Prefix => New_Copy_Tree (Prefix (Name))));
Set_Analyzed (Parent (Expr), False);
end if;
end if;
return OK;
end Replace_Type;
procedure Replace_Self_Reference is
new Traverse_Proc (Replace_Type);
-- Start of processing for Make_OK_Assignment_Statement
begin
Set_Assignment_OK (Name);
if Self_Ref then
Replace_Self_Reference (Expression);
end if;
return Make_Assignment_Statement (Sloc, Name, Expression);
end Make_OK_Assignment_Statement;
......@@ -5393,6 +5712,12 @@ package body Exp_Aggr is
return False;
end if;
if not Is_Scalar_Type (Component_Type (Typ))
and then Has_Non_Standard_Rep (Component_Type (Typ))
then
return False;
end if;
declare
Csiz : constant Nat := UI_To_Int (Component_Size (Typ));
......@@ -5774,4 +6099,109 @@ package body Exp_Aggr is
end loop;
end Sort_Case_Table;
----------------------------
-- Static_Array_Aggregate --
----------------------------
function Static_Array_Aggregate (N : Node_Id) return Boolean is
Bounds : constant Node_Id := Aggregate_Bounds (N);
Typ : constant Entity_Id := Etype (N);
Comp_Type : constant Entity_Id := Component_Type (Typ);
Agg : Node_Id;
Expr : Node_Id;
Lo : Node_Id;
Hi : Node_Id;
begin
if Is_Tagged_Type (Typ)
or else Is_Controlled (Typ)
or else Is_Packed (Typ)
then
return False;
end if;
if Present (Bounds)
and then Nkind (Bounds) = N_Range
and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal
and then Nkind (High_Bound (Bounds)) = N_Integer_Literal
then
Lo := Low_Bound (Bounds);
Hi := High_Bound (Bounds);
if No (Component_Associations (N)) then
-- Verify that all components are static integers.
Expr := First (Expressions (N));
while Present (Expr) loop
if Nkind (Expr) /= N_Integer_Literal then
return False;
end if;
Next (Expr);
end loop;
return True;
else
-- We allow only a single named association, either a static
-- range or an others_clause, with a static expression.
Expr := First (Component_Associations (N));
if Present (Expressions (N)) then
return False;
elsif Present (Next (Expr)) then
return False;
elsif Present (Next (First (Choices (Expr)))) then
return False;
else
-- The aggregate is static if all components are literals,
-- or else all its components are static aggregates for the
-- component type.
if Is_Array_Type (Comp_Type)
or else Is_Record_Type (Comp_Type)
then
if Nkind (Expression (Expr)) /= N_Aggregate
or else
not Compile_Time_Known_Aggregate (Expression (Expr))
then
return False;
end if;
elsif Nkind (Expression (Expr)) /= N_Integer_Literal then
return False;
end if;
-- Create a positional aggregate with the right number of
-- copies of the expression.
Agg := Make_Aggregate (Sloc (N), New_List, No_List);
for I in UI_To_Int (Intval (Lo)) .. UI_To_Int (Intval (Hi))
loop
Append_To
(Expressions (Agg), New_Copy (Expression (Expr)));
Set_Etype (Last (Expressions (Agg)), Component_Type (Typ));
end loop;
Set_Aggregate_Bounds (Agg, Bounds);
Set_Etype (Agg, Typ);
Set_Analyzed (Agg);
Rewrite (N, Agg);
Set_Compile_Time_Known_Aggregate (N);
return True;
end if;
end if;
else
return False;
end if;
end Static_Array_Aggregate;
end Exp_Aggr;
gcc/ada/exp_aggr.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2007, 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- --
......@@ -47,6 +47,16 @@ package Exp_Aggr is
-- assignment in the newly allocated object.
procedure Convert_Aggr_In_Assignment (N : Node_Id);
-- ??? documentation needed
-- If the right-hand side of an assignment is an aggregate, expand the
-- statement into a series of individual component assignments. This is
-- done if there are non-static values involved in either the bounds or
-- the components, and the aggregate cannot be handled as a whole by the
-- backend.
function Static_Array_Aggregate (N : Node_Id) return Boolean;
-- N is an array aggregate that may have a component association with
-- an others clause and a range. If bounds are static and the expressions
-- are compile-time known constants, rewrite N as a purely positional
-- aggregate, to be use to initialize variables and components of the type
-- without generating elaboration code.
end Exp_Aggr;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment