[Ada] fixes in handling of aggregates
Arnaud Charlet
charlet@adacore.com
Fri Jun 8 09:29:00 GMT 2007
Tested on i686-linux, committed on trunk
Add missing initialization of secondary tags in extension aggregates.
After this patch, gnat.dg/aggr3.adb compiles and executes without errors.
Also, in order to minimize elaboration code, we recognize composite types whose
default values can be represented by a static aggregate. When an object of the
type is declared without an explicit initialization, we use this constructed
aggregate as a default expression, instead of a call to the initialization
procedure for the type.
In call to Init_Controller, pass False to Init_Pr, instead of
Ancestor_Is_Expression. Otherwise, for an extension aggregate like "(X with
Y)", Init_Controller will overwrite the record controller for the parent part,
thus losing track of X, so the parent part will not be finalized.
The following test should print:
Main
Hello from Adjust (Controlled_1)
Hello from Adjust (Controlled_2)
block
Proc_1
block done
Hello from Finalize (Controlled_2)
Hello from Finalize (Controlled_1)
Main done
procedure Extension_Agg_Test.Main is
X : Parent;
Y : Controlled_2;
begin
Put_Line ("Main");
Verbose := True;
declare
Derived_Object : Derived := (X with Y);
begin
Put_Line ("block");
Proc_1 (Derived_Object);
Put_Line ("block done");
end;
Verbose := False;
Put_Line ("Main done");
end Extension_Agg_Test.Main;
package body Extension_Agg_Test is
procedure Proc_1 (X : Parent'Class) is
begin
if Verbose then
Put_Line ("Proc_1");
end if;
end Proc_1;
procedure Initialize (X : in out Controlled_1) is
begin
if Verbose then
Put_Line ("Hello from Initialize (Controlled_1)");
end if;
end Initialize;
procedure Adjust (X : in out Controlled_1) is
begin
if Verbose then
Put_Line ("Hello from Adjust (Controlled_1)");
end if;
end Adjust;
procedure Finalize (X : in out Controlled_1) is
begin
if Verbose then
Put_Line ("Hello from Finalize (Controlled_1)");
end if;
end Finalize;
procedure Initialize (X : in out Controlled_2) is
begin
if Verbose then
Put_Line ("Hello from Initialize (Controlled_2)");
end if;
end Initialize;
procedure Adjust (X : in out Controlled_2) is
begin
if Verbose then
Put_Line ("Hello from Adjust (Controlled_2)");
end if;
end Adjust;
procedure Finalize (X : in out Controlled_2) is
begin
if Verbose then
Put_Line ("Hello from Finalize (Controlled_2)");
end if;
end Finalize;
end Extension_Agg_Test;
with Ada.Finalization; use Ada.Finalization;
with GNAT.IO; use GNAT.IO;
package Extension_Agg_Test is
type Controlled_1 is new Controlled with null record;
procedure Initialize (X : in out Controlled_1);
procedure Adjust (X : in out Controlled_1);
procedure Finalize (X : in out Controlled_1);
type Controlled_2 is new Controlled with null record;
procedure Initialize (X : in out Controlled_2);
procedure Adjust (X : in out Controlled_2);
procedure Finalize (X : in out Controlled_2);
type Parent is tagged
record
Comp1 : Controlled_1;
end record;
procedure Proc_1 (X : Parent'Class);
type Derived is new Parent with
record
Comp2 : Controlled_2;
end record;
Verbose : Boolean := False;
end Extension_Agg_Test;
The explicit initialization of a record by means of an aggregate is
incomplete in case of tagged types covering abstract interfaces. After
this patch, gnat.dg/test_ifaces.adb compiles and executes without errors.
Finally, in processing record aggregates, one case was missed for testing
cases that the back end cannot handle, namely the case where one of the
aggregate values is a possibly bit aligned component, causing a back end
blow up trying to process the resulting aggregate. An appropriat test has
been added to expand the aggregate to assignments in this case. A similar
change is made for array aggregates (though it is not clear that this is
absolutely necessary, since in practice it seems like this is taken care
of by other checks, but it is certainly more secure to add the check.
gnat.dg/aggr4.adb should compile cleanly.
2007-06-06 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.
-------------- next part --------------
Index: exp_aggr.ads
===================================================================
--- exp_aggr.ads (revision 124068)
+++ exp_aggr.ads (working copy)
@@ -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;
Index: exp_aggr.adb
===================================================================
--- exp_aggr.adb (revision 124068)
+++ exp_aggr.adb (working copy)
@@ -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 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) then
+ 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.
-
- --------------------------------------------------
- -- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps --
- --------------------------------------------------
+ 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.
+
+ 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.
+
+ ----------------------------------
+ -- Component_Not_OK_For_Backend --
+ ----------------------------------
- function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean is
+ 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;
More information about the Gcc-patches
mailing list