From 0f95b178458d196841d4d4778cfd1c244088b55b Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Wed, 6 Jun 2007 12:23:46 +0200 Subject: [PATCH] exp_aggr.ads, [...]: 2007-04-20 Javier Miranda Ed Schonberg Bob Duff Hristian Kirtchev * 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 --- gcc/ada/exp_aggr.adb | 754 +++++++++++++++++++++++++++++++++---------- gcc/ada/exp_aggr.ads | 16 +- 2 files changed, 605 insertions(+), 165 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 97df2bc880fc..6321dc55d748 100644 --- a/gcc/ada/exp_aggr.adb +++ b/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; diff --git a/gcc/ada/exp_aggr.ads b/gcc/ada/exp_aggr.ads index 65897df5d66f..4a265119a90d 100644 --- a/gcc/ada/exp_aggr.ads +++ b/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; -- 2.43.5